! "W N, R=    @ #D  D ҃TP  B ы e@W 0 ,"& 7   0ߋp@E A Ze      |@7x@ eE "  ɋ -lɋ e-RNHɋ ^?alog.matŁ r atan.matő r  _conv2.matŁ r -conv3.matŁ r 3fermod.matŁ r 7Eexp.matŁ &r <!5fadd.matő r Dufdiv.matő ""r Tb]fmul.matő M#r f]fpassem r xMintr.matŁ 8r ylinkrő $r {xAmacroő *7r /0making.basic r map.of.basic r bmatrix.info Ar 'p3.matŁ r 4p3.nofpuŁ r sin.matŁ r Bsqrt.matŁ r vsysmac.sml Hr iupdate.news r +* .title alog single precision log .globl alog,alog10 .ifndf fpu .globl $adr,$sbr,$mlr,$dvr,$ir .endc ; the fortran alog and alog10 functions ; calling sequence: ; fortran standard ; returns ln(arg) (or log10(arg)) in r0,r1. errdef .ifndf fpu alog10: mov @pc,-(sp) ;get 0004xx as a flag br log alog: clr -(sp) ;flag alog log: mov 2(r5),r4 ;get arg address mov #071030,-(sp) ;push -1/2*ln(2) mov #137661,-(sp) cmp -(sp),-(sp) ;get work space mov 2(r4),-(sp) ;get arg mov @r4,-(sp) ble error ;jump if not positive asl @sp movb 1(sp),12.(sp) ;get exponent movb #200,1(sp) ;transform arg to (1/2,1) ror @sp mov #002363,-(sp) ;push 1/2*root2 mov #040065,-(sp) mov 6(sp),-(sp) ;push x mov 6(sp),-(sp) mov #002363,-(sp) ;push 1/2*root2 mov #040065,-(sp) mov (sp)+,r4 jsr r4,@(pc)+ .word $sbr,up,$adr,$dvr ;get (x-root2)/ ;(x+root2) .word dup,dup ;get three copies .word $mlr,reg,stack,stack,stack ;set up polynomial .word $mlr,$adr,$mlr,$adr,$mlr,$adr,$mlr,$adr ;expand polynomial .word scale,$ir,pln2,$mlr ;get ln(exp) .word $adr,exit ;combine with fraction ;and check if done .word $mlr,exit ;multiply by log10(e) and return reg: mov (sp)+,r0 ;pop y mov (sp)+,r1 mov #consts+4,r2 ;point to coefficients br stackc stack: mov r1,-(sp) ;push y mov r0,-(sp) stackc: mov -(r2),-(sp) ;push coefficient mov -(r2),-(sp) jmp @(r4)+ up: mov (sp)+,10.(sp) ;move item to work space mov (sp)+,10.(sp) jmp @(r4)+ scale: clr -(sp) bisb 6(sp),@sp ;get exponent sub #200,@sp ;remove excess 128 jmp @(r4)+ dup: mov 2(sp),-(sp) mov 2(sp),-(sp) ;duplicate stack item jmp @(r4)+ pln2: mov #071030,-(sp) ;push ln(2) mov #040061,-(sp) jmp @(r4)+ exit: decb 5(sp) ;check for alog10 blt logout ;no, done mov #055731,-(sp) ;push log10(e) mov #037736,-(sp) jmp @(r4)+ logout: mov (sp)+,r0 ;pop result mov (sp)+,r1 tst (sp)+ ;flush flag ret: rts pc error: add #14.,sp error badlog br ret .endc .ifdf fpu f0=%0 f1=%1 f2=%2 f3=%3 alog10: mov @pc,r4 ;get 0004xx as alog10 flag br log alog: clr r4 ;get 0 as alog flag log: setf ;single precision fp seti ;short integers mov #fconst,r0 ;pointer to constants for routine ldf @2(r5),f2 ;get argument cfcc ble error ;jump if not positive stexp f2,r1 ;get exponent of arg ldcif r1,f3 ;convert t o fp form mulf (r0)+,f3 ;scale factor=exponent*ln(2) ldexp #0,f2 ;transform arg to (1/2,1) ldf f2,f1 subf (r0),f2 ;x-1/2*sqrt(2) addf (r0)+,f1 ;x+1/2*sqrt(2) divf f1,f2 ;w=(x-root2)/(x+root2) ldf f2,f1 mulf f1,f1 ;y= w**2 mov #3,r1 ;count of consts for polynomial ldf (r0)+,f0 ;initialize accumulator for polynomial xpand: mulf f1,f0 dec r1 ;count addf (r0)+,f0 ;f0:= y*f0 + c(i) bgt xpand ;loop mulf f2,f0 addf (r0)+,f0 ;f0:= w*f0 - 1/2*ln(2) addf f3,f0 ;add scale factor for exponent tst r4 ;test alog10 flag beq logout mulf (r0)+,f0 ;alog10:= alog*log10(e) logout: stf f0,-(sp) ;move result to stack mov (sp)+,r0 mov (sp)+,r1 ;and thence to r0,r1 ret: rts pc error: error badlog br ret ; order-dependent constants for routine ; r0 points at current constant in fpu version fconst: .word 040061,071030 ;ln(2) .word 040065,002363 ;1/2*sqrt(2) .endc ; constants for polynomial expansion .word 037632,014525 ;.300974506 .word 037714,120036 ;.399659100 .word 040052,125332 ;.666669471 consts: .word 040400,000000 ;1.99999999 .ifdf fpu ; more order-dependent constants .word 137661,071030 ;-1/2*ln(2) .word 037736,055731 ;log10(e) .endc .end r1 ret: rts pc error: error badlog br ret ; order-dependent constants for rou .title atan arctangent .globl atan,atan2 .ifndf fpu .globl $adr,$sbr,$mlr,$dvr,$popr3 .endc ; the fortran atan and atan2 functions ; calling sequence for atan: ; fortran standard (1 arg) ; returns arctan(arg) in r0 and r1. ; calling sequence for atan2: ; fortran standard (2 args) ; returns acrtan(arg1/arg2) in r0 and r1. ; if abs(arg1/arg2) > 2**24, the result is ; sign(arg1)*pi/2. ; if arg2 <0 the result is arctan(arg1/arg2) + ; sign(arg1)*pi. finit .ifndf fpu atan2: clr -(sp) ;clear sign flag clr -(sp) ;clear atan2 bias clr -(sp) clr -(sp) ;clear quadrant bias clr -(sp) mov 2(r5),r4 ;get first arg address mov 2(r4),-(sp) ;get first arg mov @r4,-(sp) mov @sp,r0 ;arg1 to r0 mov 4(r5),r4 ;get second arg address mov 2(r4),-(sp) ;get second arg mov @r4,-(sp) mov @sp,r1 ;arg2 to r1 beq inf ;jump if denominator is 0 asl r0 ;get abs val arg1 clrb r0 ;get exponent swab r0 asl r1 clrb r1 ;get exponent arg2 swab r1 sub r1,r0 ;get exponent difference cmp #26.,r0 ;check magnitude blt inf ;treat as infinity div: mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ .word $dvr,unpol ;get arg1/arg2 unpol: tst @4(r5) ;if arg2 >0, bias =0 bge atane ;if arg2<0, bias=sign(arg1)*pi mov #040511,8.(sp) ;pi mov #007733,10.(sp) tst @2(r5) ;test arg1 bge atane add #100000,8.(sp) ;-pi atane: tst @sp ;set codes br atan1 ;join main routine inf: add #18.,sp ;flush stack mov #040311,r0 ;ans = sign(arg1)*pi/2 mov #007733,r1 tst @2(r5) ;test arg1 bge infr ;jump if +pi/2 add #100000,r0 ;-pi/2 infr: rts pc ;return to user atan: clr -(sp) ;clear sign flag clr -(sp) ;clear atan2 bias clr -(sp) clr -(sp) ;clear quadrant bias clr -(sp) mov 2(r5),r4 ;get arg address mov 2(r4),-(sp) ;get low order arg mov @r4,-(sp) ;get high order atan1: bge plus ;jump if quadrant 1 or 3 add #100000,@sp ;get abs value inc 12.(sp) ;flag - plus: cmp @sp,#40200 ;check if <1. blo le1 ;jump if <1. bgt gt1 ;>1. tst 2(sp) ;check low order beq le1 ;=1. gt1: mov #140311,4(sp) ;-pi/2 mov #007733,6(sp) ;atan(x)=pi/2-atan(1/x) dec 12.(sp) ;adjust sign mov 2(sp),-(sp) ;move arg down mov 2(sp),-(sp) mov #40200,4(sp) ;insert 1. clr 6(sp) mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ .word $dvr,le1 le1: mov 2(sp),-(sp) ;move arg down mov 2(sp),-(sp) clr 4(sp) clr 6(sp) cmp @sp,#037611 ;tan(15) blo lt15 ;jump if less than tan(15) bhi trans ;jump if > cmp 2(sp),#030243 blos lt15 trans: mov #040006,4(sp) ;insert pi/6 mov #005222,6(sp) mov @sp,r0 ;arg to regs mov 2(sp),r1 mov #131727,-(sp) ;push -root 3 mov #140335,-(sp) mov r1,-(sp) mov r0,-(sp) ;push arg clr -(sp) ;push 1. mov #40200,-(sp) mov #131727,-(sp) ;push root3 mov #040335,-(sp) mov r1,-(sp) ;push arg mov r0,-(sp) mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ ;transform arg ;(root3*x-1)/(root3 +x) .word $mlr,$sbr,up,$sbr,$dvr,lt15 lt15: mov @sp,r0 ;get arg mov 2(sp),r1 mov r1,-(sp) ;get three copies mov r0,-(sp) mov r1,-(sp) mov r0,-(sp) mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ .word $mlr ;get arg**2 .word poly ;set up coefficients .word $mlr,$adr,$mlr,$adr,$mlr,$adr .word $mlr,$adr,$mlr,$adr .word $adr ;p(x)+0 if x<=1, p(x)-pi/2 if x>1 .word sign ;adjust sign .word $adr ;add atan2 bias .word $popr3,exit ;pop result to regs exit: tst (sp)+ ;pop sign flag rts pc ;return to user up: mov (sp)+,10.(sp) ;move stack item up mov (sp)+,10.(sp) jmp @(r4)+ poly: mov (sp)+,r0 ;pop poly arg mov (sp)+,r1 mov #consts+4,r2 ;point to coefficient table mov #5,r3 ;loop 5 br poly1 poly2: mov r1,-(sp) ;push arg mov r0,-(sp) poly1: mov -(r2),-(sp) ;push constant mov -(r2),-(sp) dec r3 ;count bgt poly2 jmp @(r4)+ sign: tst 8.(sp) ;check sign flag beq sign1 add #100000,@sp ;negate result for (-1,0) & (1,inf) sign1: jmp @(r4)+ .endc .ifdf fpu f0=%0 f1=%1 f2=%2 f3=%3 f4=%4 f5=%5 atan2: setf ;set fp mode for fpu mov 2(r5),r3 ;address of arg1 mov 4(r5),r4 ;address of arg2 mov @r3,r0 ;high order arg1 mov @r4,r1 ;high order arg2 beq inf ;jump if denominator 0 asl r0 clrb r0 swab r0 ;exponent of arg1 asl r1 clrb r1 swab r1 ;exponent of arg2 sub r1,r0 ;get exponent difference cmp #26.,r0 ;check magnitude blt inf ;treat as infinite ldf pi,f3 ;initialize bias=pi ldf @r3,f0 ;get arg1 cfcc bge a1plus ;jump if arg1>0 negf f3 ;bias=sign(arg1)*pi a1plus: ldf @r4,f1 ;get arg2 cfcc blt a2neg clrf f3 ;if arg2>0, bias=0 a2neg: divf f1,f0 ;arg1/arg2, set float cc br atan1 ;join main routine inf: ldf pi2,f1 ;result=sign(arg1)*pi/2 tst @r3 ;test arg1 bge exit ;+pi/2 negf f1 ;-pi/2 br exit atan: setf ;set fp mode for fpu clrf f3 ;clear atan2 bias ldf @2(r5),f0 ;get argument atan1: clr r4 ;clear sign flag cfcc ;get sign of argument stf f3,f5 ;f5=atan2 bias clrf f3 ;clear quadrant bias bge plus ;jump if quadrant 1 or 3 absf f0 ;abs(x) inc r4 ;flag - plus: ldf #^f1.0,f1 ;1.0 cmpf f0,f1 ;check if x<=1.0 cfcc ble le1 gt1: dec r4 ;x>1.0, adjust sign flag divf f0,f1 ;1.0/x ldf f1,f0 ;atan(x)=pi/2-atan(1/x) ldf pi2,f3 ;quadrant bias=pi/2 le1: stf f3,f4 ;f4=quadrant bias clrf f3 ;f3=0.0 cmpf tan15,f0 ;compare tan(15) : x cfcc bge lt15 ;x<= tan(15) ldf pi6,f3 ;f3=pi/6 ldf f0,f1 mulf root3,f0 subf #^f1.0,f0 ;x*root3-1.0 addf root3,f1 ;x+root3 divf f1,f0 ;(x*root3-1.0)/(x+root3) lt15: ldf f0,f2 ;x mulf f0,f0 ;x**2 mov #fconst,r0 ;pointer to polynomial constants mov #4,r1 ;count of coefficients ldf (r0)+,f1 ;initialize accumulator xpand: mulf f0,f1 dec r1 ;count addf (r0)+,f1 ;f1:= f1* x**2 + c(i) bgt xpand ;loop mulf f2,f1 ;f1:= f1*x addf f3,f1 ;pi/6 or 0.0 subf f4,f1 ;p(x)-quad bias tst r4 ;test sign flag beq sign1 ;no adjustment negf f1 ;negate result for (-1,0)&(1,inf) sign1: addf f5,f1 ;atan2 bias exit: stf f1,-(sp) ;move result to stack mov (sp)+,r0 ;and then to registers mov (sp)+,r1 rts pc ;exit pi: .word 040511,007733 ;pi pi2: .word 040311,007733 ;pi/2 tan15: .word 037611,030243 ;tan(15) pi6: .word 040006,005222 ;pi/6 root3: .word 040335,131727 ;root3 .endc fconst: .word 037305,035302 ;.0963034789 .word 137421,056514 ;-.1419574624 .word 037514,143333 ;.1999773201 .word 137652,125244 ;-.3333331319 consts: .word 040200,000000 ;.9999999999 .end ,0)&(1,inf) sign1: addf f5,f1 ;atan2 bias exit: stf f1,-(sp) ;move result to stack mov (sp)+,r0 ;and then to registers mov (sp)+,r1 rts pc ;exit pi: .word 040511,007733 ;pi pi2: .word 040311,007733 ;pi/2 tan15: .word 037611,030243 ;tan(15) pi6: .word 040006,005222 ;pi/6 root3: .word 040335,131727 ;root3 .endc fcons .title conv2 convert to integer or logical .globl $ri .ifndf $basic .globl $di .globl cif$,cid$,cic$,cil$ .globl clf$,cld$,clc$,cli$ ; real to integer conversion. ; argument is a double word real number on the top ; of the stack. ; truncate it and convert it to an integer on the ; top of the stack. errdef .ifdf fpu f0=%0 clc$: cic$: $ci: clr 4(sp) ;imaginary part =0.0 clr 6(sp) cld$: cid$: $di: setd ;double precision br ridi clf$: cif$: .endc ;$basic $ri: ridi: seti ;short integers ldd (sp)+,f0 ;get argument stcdi f0,-(sp) ;convert to stack ;overflow check missing setf ;always leave in single mode jmp @(r4)+ ;return .endc .ifdf eae!muldiv .ifndf ;$basic clc$: cld$: cic$: cid$: $di: mov (sp)+,2(sp) ;truncate to real format mov (sp)+,2(sp) clf$: cif$: .endc ;$basic $ri: clr r2 ;clear work space inc r2 ;set up normal bit mov (sp)+,r1 ;get real argument rol @sp ;get sign rol r1 ;and rol -(sp) ;save it movb r1,r3 ;get high order fraction clrb r1 swab r1 ;get exponent sub #201,r1 blt zero ;jump if it is too small beq done cmp #15.,r1 blt over ;jump if it is too big swab r3 ;form 16 bits of high order fraction clrb r3 bisb 3(sp),r3 shft: ; eae code .ifdf eae mq=177304 lsh=177314 mov #mq,r0 ;point to mq mov r3,@r0 ;insert fraction mov r2,-(r0) mov r1,@#lsh ;shift left mov @r0,r2 ;result to reg .endc ; muldiv code .ifdf muldiv .word 073201 ; ;ashc r1,r2 .endc done: neg r2 ;make - bvs negm ;jump if possible negmax bgt over ;jump if more than 15 bits sign: ror (sp)+ ;get sign bcs out ;jump if - neg r2 ;- result out: mov r2,@sp ;store integer result jmp @(r4)+ ;return to caller negm: ror (sp)+ bcs out ;ok if result to be - over: tst -(sp) ;fake sign error intov ;integer overflow zero: clr r2 ;answer is 0 br sign .endc .ifndf eae&muldiv&fpu ; h.j., rl .ifndf $basic $di: cld$: clc$: cid$: cic$: mov (sp)+,2(sp) mov (sp)+,2(sp) ;pop 2 words off the stack clf$: cif$: .endc ;$basic $ri: mov (sp)+,r0 mov (sp)+,r1 ;get number into regs asl r0 ;get sign ror r3 ;save for result sec rorb r0 ;insert implied norm bit mov r0,r2 clrb r2 ;seperate into 2-8 bit hunks bic r2,r0 swab r2 bpl 5$ ;branch if number definitely <.5 ; an ugly- if number >.5, <1 then 8 shifts will be done to generate 0 cmp #220,r2 ;check exp bhi 1$ ;branch if no overflow error intov ;integer overflow 5$: clr r0 ;set result to 0 br 4$ 2$: asl r1 ;shift mantissa left rol r0 ;to form result >256 and dec r2 ;decrement exp 1$: cmp #210,r2 ;will result be greater than 256 blt 2$ ;branch if yes to shift num left beq 3$ ;branch if result formed inc r2 ;increment exp for right shift asr r0 ;shift num right bne 1$ ;branch as long as result >0 3$: tst r3 ;check for final sign bpl 4$ ;branch if to be positive neg r0 4$: mov r0,-(sp) ;put result back on stack jmp @(r4)+ .endc cil$: movb @sp,r0 ;convert byte to word mov r0,@sp cli$: jmp @(r4)+ .end left rol r0 ;to form result >256 and dec r2 ;decrement exp 1$: cmp #210,r2 ;will .title conv3 converts from integer to anything .globl $ir .ifndf $basic .globl $id,$ic .globl cfi$,cdi$,cci$ .endc ;$basic ; integer to real conversion. ; argument is a full word on the top of the stack ; convert it to real format and return it as the top ; two words on the stack. r0=%0 r1=%1 r2=%2 r3=%3 r4=%4 r5=%5 sp=%6 pc=%7 .ifdf fpu f0=%0 .ifndf $basic cci$: cdi$: $ic: $id: setd br idir cfi$: .endc ;$basic $ir: idir: seti ;short integers ldcif (sp)+,f0 ;convert stf f0,-(sp) ;result to stack setf ;leave fpu in single mode cli$: jmp @(r4)+ .endc .ifndf fpu .ifndf $basic cci$: cdi$: $ic: $id: mov @sp,-(sp) ;push argument down mov @sp,-(sp) clr 2(sp) ;clear lowest order double clr 4(sp) cfi$: .endc ;$basic $ir: clr -(sp) ;make room for result mov 2(sp),r1 ;get integer argument bgt pos beq zero neg r1 ;get absolute value pos: rol -(sp) ;save sign .ifndf eae mov #220,r2 ;get max. possible exponent +1 .endc ; eae code .ifdf eae mq=177304 nor=177312 mov #217,r2 ;get max. possible exponent .endc clrb 4(sp) ;clear lowest order fraction norm: .ifndf eae rol r1 ;look for normal bit bcs normd ;jump if found dec r2 ;decrease exponent br norm ;try again .endc ; eae code .ifdf eae mov #mq,r3 ;point to mq clr @r3 mov r1,-(r3) ;move arg mov #nor,r0 ;point to nor in eae clr @r0 ;normalize fraction sub (r0)+,r2 ;tell exponent mov #2,@r0 ;shift out normal bit by lsh mov @r3,r1 ;result to r1 .endc normd: movb r1,5(sp) ;save low order fraction clrb r1 bisb r2,r1 ;combine exponent and high order fraction swab r1 ror (sp)+ ;get sign ror r1 ;insert sign in result rorb 3(sp) mov r1,@sp ;output result zero: jmp @(r4)+ .endc .end ry again .endc ; eae code .ifdf eae mov #mq,r3 ;point to mq clr @r3 mov r1,-(r3) ;move arg mov #nor,r0 ;point to nor in eae clr @r0 ;normalize fraction sub (r0)+,r2 ;tell exponent mov #2,@r0 ;shift out normal bit by lsh mov @r3,r1 ;result to r1 .endc normd: movb r1,5(sp) ;save low order fraction clrb r1 .globl msgerr,bombdd,error.,usrare,ifpmp,$ervec .title ermod error module ;this module handles the error reporting from the ots math routines. finit error.: mov r1,-(sp) mov r0,-(sp) mov r5,-(sp) mov usrare,r5 ;r5 -> user partition. mov (r4)+,r1 ;fetch error code. mov ermes(r1),pc fov: ercon fov, br er.com fun: ercon fun, br er.com fzd: ercon fzd, br er.com ngs: ercon ngs, br er.com blg: ercon blg, br er.com iov: ercon iov, er.com: mov lineno(r5),r1 ;set up to print out the line number. blt 1$ jsr pc,bombdd 1$: mov (sp)+,r5 mov (sp)+,r0 mov (sp)+,r1 rts r4 ermes: .word fov .word fun .word fzd .word ngs .word blg .word iov ifpmp: .if df fpu .ifdf hvunix $sig ^d8 $fperr .iff 170127 ;ldfps -- enable fpu interrupt. 1000 .sfpa #$fperr .endc .endc ;fpu rts pc $ervec: .word 0 ;compatibility with gt40 package! .if df fpu f0=%0 f1=%1 f2=%2 f3=%3 $fperr: .ifdf hvunix $sig ^d8 $fperr .endc mov r0,-(sp) stfps r0 ;get fpu interrupt word. bic #100000,r0 ;clear error flag. ldfps r0 ;restore int. word. mov 2(sp),r0 ;get the flt. exception code. asl r0 ;convert to word offset. jmp errs-10(r0) ;do the error call. errs: error fzdiv ;divide by 0 br out error intov ;floating to integer conversion br out error fovrfl ;floating overflow br out error fundfl ;floating underflow br out mov 4(sp),r0 ;get the underflowing instruction ror r0 ror r0 ror r0 ror r0 bic #177763,r0 ;r0 = ac*4 jmp clrf0(r0) ;clear the correct fltg. ac. clrf0: clrf f0 br out clrf f1 br out clrf f2 br out clrf f3 out: mov (sp)+,r0 ;pop fltg. exception address out1: cmp (sp)+,(sp)+ ;restore the stack. rti .endc ;fpu .if df fis $fperr: mov r0,-(sp) bit #1,4(sp) ;divide by zero? beq 1$ ;branch if no error fzdiv br out 1$: bit #10,4(sp) ;underflow? beq 2$ ; branch if not. error fundfl br out 2$: error fovrfl ;floating overflow out: mov (sp)+,r0 mov (sp)+,2(sp) ;mov pc,ps up mov (sp)+,2(sp) ;overwriting the b arg. clr 4(sp) ;default value of 0.0 clr 6(sp) ; rti .endc ;fis .end t clrf f3 out: mov (sp)+,r0 ;pop fltg. exception address out1: cmp (sp)+,(sp)+ ;restore the stack. rti .endc ;fpu .if df fis $fperr: mov r0,-(sp) bit #1,4(sp) ;divide by zero? beq 1$ ;branch if no error fzdiv br out 1$: bit #10,4(sp) ;underflow? beq 2$ ; branch if not. error fundfl br out 2$: error fovrfl ;floating overf .title exp routine .globl exp .ifndf fpu .globl $adr,$sbr,$mlr,$dvr,$ir,$ri .endc ; exp the real exponentiation routine ; calling sequence: ; fortran standard (1 arg) ; returns exponential in r0 and r1. errdef exp: mov 2(r5),r4 ;get argument pointer mov @r4,r0 ;get high order arg bgt pos ;jump if arg + cmp r0,#141660 bhi zero ;jump if exponent < -88.7 br smtst pos: cmp r0,#41660 bhi over ;jump if exponent > 87 smtst: asl r0 ;dump sign cmp r0,#63000 blo one ;jump if exponent magnitude < 2**-28 .ifndf fpu tst -(sp) ;save space for scale clr -(sp) ;push a 1. mov #40200,-(sp) mov 2(r4),-(sp) ;get low order argument mov @r4,-(sp) ;high order mov 2(r4),-(sp) ;need two copies of it mov @r4,-(sp) mov (sp)+,r4 jsr r4,@(pc)+ .word pl2e ;push log2(e) .word $mlr .word $ri ;fix log2(e)*x .word esave ;save exponent scale .word $ir ;float it .word pl2e ;push log2(e) .word $dvr .word $sbr .word cfract ;push continued fraction constants .word $mlr ;y*y .word $adr ;b1+y*y .word $dvr ;a1/(b1+y*y) .word $adr ;y+a1/(b1+y*y) .word $adr ;a0+y+a1/(b1+y*y) .word $dvr ;y/(a0+y+a1/(b1+y*y)) .word inc ;-2*y/(a0+y+a1/(b1+y*y)) .word $adr ;1-2*y/......... .word dup ;duplicate it .word $mlr ;(1-2*y/.....)**2 .word scale ;exit polish mode and scale result inc: add #100200,@sp ;multiply by -2.0 jmp @(r4)+ ;go back to list dup: mov 2(sp),-(sp) ;duplicate stack item mov 2(sp),-(sp) jmp @(r4)+ pl2e: mov #125073,-(sp) ;push log2(e) mov #40270,-(sp) jmp @(r4)+ esave: mov @sp,10.(sp) ;save exponent scale jmp @(r4)+ cfract: rol @sp ;shift modified arg rol r0 ;save sign sub #400,@sp ;divide by 2. blos zfract ;underflow. make arg 0 ror r0 ;get sign back ror @sp mov @sp,r0 ;get modified argument mov 2(sp),r1 ;in registers mov #036602,-(sp) ;push -12.01501675 *********** mov #141100,-(sp) mov r1,-(sp) mov r0,-(sp) mov #071571,-(sp) ;push 601.8042667 *************** mov #042426,-(sp) mov #056133,-(sp) ;push 60.0901907 *********** mov #041560,-(sp) mov r1,-(sp) mov r0,-(sp) mov r1,-(sp) mov r0,-(sp) jmp @(r4)+ .endc .ifdf fpu f0=%0 f1=%1 f2=%2 f3=%3 setd ;double precision argument reduction seti ;short integers mov #fconst,r0 ;pointer to constants ldcfd @r4,f2 ;get argument modd (r0)+,f2 ;f2=fract(x*log2(e)) stcdi f3,r4 ;r4=int (x*log2(e)) ldd #^f1.0,f0 ;f0=1.0 divd (r0)+,f2 ;y=f2/(2*log2(e)) setf ldcdf f2,f2 ;rest in single precision cfcc ;test for underflow beq scale1 ;approximation result is 1.0 ldf f2,f3 mulf f3,f3 ;y*y addf (r0)+,f3 ;b1+y*y ldf (r0)+,f1 divf f3,f1 ;a1/(b1+y*y) addf f2,f1 addf (r0)+,f1 ;a0+y+a1/(b1+y*y) divf f1,f2 ;y/(a0+y+a1/(b1+y*y)) mulf #^f2.0,f2 subf f2,f0 ;1-2*y/. . . mulf f0,f0 ;(1-2*y/. . . )**2 scale1: stf f0,-(sp) ;move approximation to stack .endc .ifndf fpu zfract: cmp (sp)+,(sp)+ ;flush cfract arg ; result is 1. .endc scale: mov (sp)+,r0 ;get approximation result mov (sp)+,r1 .ifndf fpu mov (sp)+,r4 ;get int(x*log2(e)) .endc swab r4 ;make into exponent modifier clrb r4 asr r4 add r4,r0 ;add in exponent modifier bmi over ;test overflow rts pc one: clr r1 mov #40200,r0 ;exp(tiny) = 1. br out over: error fovrfl br ecall zero: error fundfl ecall: clr r0 ;return 0 clr r1 out: rts pc .ifdf fpu ; order-dependent constants fconst: .word 040270,125073 ;log2(e) double precision .word 024534,013761 .word 040470,125073 ;2*log2(e) double precision .word 024534,013761 .word 041560,056133 ;b1=60.0901907 .word 042426,071571 ;a1=601.8042667 .word 141100,036602 ;a0=-12.01501675 .endc .end exponent modifier bmi over ;test overflow rts pc one: clr r1 mov #40200,r0 ;exp(tiny) = 1. br out over: error fovrfl br ecall zero: error fundfl ecall: clr r0 ;return 0 clr r1 out: rts pc .ifdf fpu ; order-dependent constants fconst: .word 040270,125073 ;log2(e) double precision .word 024534,013761 .word 040470,125073 ;2*log2(e) double precision .word 024534,013761 .word 041560,056133 ;b1=60.0901907 .word 042426,071571 ;a1=601.8042667 .word 141100 .title real add routines ; h.j. .globl $adr,$sbr .ifndf $basic .globl suf$is,suf$ss,suf$ms,suf$ps .globl adf$is,adf$ss,adf$ms,adf$ps errdef .endc ;$basic .ifndf fis&fpu .ifndf $basic ;the object of these interfaces is to place the numbers ;to be added into registers 0-3, clean the stack up, ;and place the destination address for the result on the stack. ;$adr is contained in this module ;add immediate constant in memory to stack adf$is: mov (r4)+,r0 ;get high order into r0 clr r1 ;clear low order br adfis ;branch into set up stack code ;add subroutine argument to stack adf$ps: mov @(r4)+,r1 ;get address of variable br adfps ;branch into memory to stack code ;subtract argument from stack suf$ps: mov @(r4)+,r1 ;get address of variable br sufps ;branch into memory to stack code ;subtract variable from stack suf$ms: mov (r4)+,r1 ;get address of variable sufps: mov (r1)+,r0 ;get high order of variable add #100000,r0 ;negate it br sufms ;branch into some add memory to stack code ;add variable to stack adf$ms: mov (r4)+,r1 ;get address of variable adfps: mov (r1)+,r0 ;get high order of variable sufms: mov (r1)+,r1 ;get low order of variable br adfms ;branch into code to handle 2nd argument ;subtract immediate value from stack suf$is: clr -(sp) ;clear low order part mov (r4)+,-(sp) ;put high order on stack ;fall into subtract stack from stack .endc ;$basic ;subtract stack from stack $sbr: suf$ss: add #100000,@sp ;negate top of stack ;fall into add stack to stack ;add stack to stack $adr: adf$ss: mov (sp)+,r0 ;get high order mov (sp)+,r1 ;get low order adfms: adfis: mov sp,r3 ;sset up r3 mov r3,-(sp) ;save destination at pseudo top ;of stack, dest. is properly set up mov (r3)+,r2 ;get high order of operand 2 mov @r3,r3 ;get low order of operand 2 ;fall into floating add .title fadd floating add routine ; h.j., rl .globl add$ ;this routine performs a floating add of the single ;precision numbers in r0:r1 and r2:r3 and places the ;result at the location left on the tos. ;precision should be good to 24 bits of mantisa add$: mov r4,-(sp) ;save r4 and r5 mov r5,-(sp) mov #2,r5 ;r5 gets signs and c gets 1 eventually asl r0 ;get sign of 1 beq noad1 ;its 0., result is 2 ror r5 ;save sign asl r2 ;get sign of 2 beq noad2 ;its 0., result is 1 rorb r5 ;save its sign mov r5,-(sp) ;put signs away for later rorb r0 ;carry is 1 - set implied norm bit mov r0,r4 ;make copy of it clrb r4 ;isolate exponent bic r4,r0 ;clear exponent out of mantissa swab r4 ;get exponent sec ;perform same for 2 rorb r2 mov r2,r5 clrb r5 bic r5,r2 swab r5 ;r4 is exp 1, r5 is exp 2 ;we want r5 to be final exponent and r4 to be negative scaler sub r5,r4 ;how are we normalized? beq algnd ;perfect bmi 5$ ;1 is smaller, scale it to 2's exp add r4,r5 ;1 is bigger, switch'em neg r4 ;fix shift count swab @sp ;correct signs mov r2,-(sp) ;switch mantissa's mov r3,r2 mov r1,r3 mov r2,r1 mov r0,r2 mov (sp)+,r0 5$: cmp #-9.,r4 ;is shift less than byte? blt bitshf ;branch if yes to do it add #16.,r4 ;is shift less than word bge bytshf ;branch if yes to byte shift clr r1 ;shift > word, clear low word add #8.,r4 ;is shift > 24 bits? bge wrdshf ;branch if not to word shift ;addend is insignificant - clean up inad: asl r3 ;force mantissa up for putting in sign rol r2 ;always leaves carry clear! inad2: swab r5 ;put exp in high part bisb r2,r5 ;put in mantissa without implied bit!! rolb (sp)+ ;get sign from stack ror r5 ;put into result ror r3 ;rescale low part mov r5,r2 ;move high part to result spot noad1: mov (sp)+,r5 ;restore registers mov (sp)+,r4 mov (sp)+,r0 ;get destination address mov r2,(r0)+ ;store high part mov r3,@r0 ;store low part jmp @(r4)+ ;link to next routine noad2: rol r5 ;get sign of 1 ror r0 ;put back into it mov r0,r2 ;move to result regs mov r1,r3 br noad1 ;branch into exit code bytshf: clrb r1 ;byte shift, low byte insignificant swab r1 ;perform byte shift swab r0 wrdshf: bis r0,r1 ;moves r0 into correct byte of r1 clr r0 ;r0 only had 1 byte, now it has none sub #8.,r4 ;refix shift count bitshf: asr r0 ;normalize to count ror r1 inc r4 bmi bitshf ;branch if not done rol r4 ;r4 is zero from shift loop - set it add r4,r1 ;to the rounding bit and round. adc r0 algnd: cmpb 1(sp),@sp ;see if signs are the same bne subt ;branch if not same to subtract add r1,r3 ;add low parts adc r2 ;add in carry to high add r0,r2 ;add high parts cmp #377,r2 ;another hack to handl@ overflow bcc inad ;branch if no carry out of mantissa incb r5 ;bump exp since we don't shift left beq 1$ ;cant alter carry so we use incb and beq sbc r4 ;this clears the carry if r4=1, thus ;preventing us from rounding twice. adc r3 ;now round with the carefully bcc inad2 ;(shortcut) adcb r2 ;manipulated carry. adcb r5 ;bump exp if mantissa overflowed twice bcc inad2 ;we are ever vigilant for overflow 1$: error fovrfl ;floating overflow setz: clr r2 clr r3 ;zero the result noad0: cmp (sp)+,r0 ;pop the signs off the stack br noad1 ;and go store it subt: sub r1,r3 ;subtract low parts sbc r2 ;reduce high by carry sub r0,r2 ;subtract high parts bmi 2$ ;make positive and fix result sign tstb r2 ;are we already normalized? bmi inad ;branch if yes dec r5 ;adjust exponent ble 6$ ;branch if underflow asr r4 ;shift round bit back in rol r3 ;normalize 1 place rol r2 beq 3$ ;branch if high part 0 to check low 5$: tstb r2 ;are we already normalized? bmi inad ;branch if yes asl r3 ;normalize result rol r2 dec r5 ;adjust exp 4$: bgt 5$ ;branch if didnt underflow 6$: error fundfl ;floating underflow br setz ;go set result to 0. 2$: swab @sp ;switch resultant sign neg r2 ;make result unsigned neg r3 sbc r2 bgt 5$ ;branch if not zero to norm it 3$: mov r3,r2 ;start with 8 bit shift beq noad0 ;branch if low part zero, result is 0. swab r3 ;test high part of low order beq 1$ ;branch if zero for 16 bit shift clr r2 ;if not just 8 bit shift bisb r3,r2 ;move high part of low order 8 bits clrb r3 ;remove them sub #8.,r5 ;adjust exp br 4$ ;normalize whats left 1$: clr r3 ;clear low order sub #16.,r5 ;adjust exp br 4$ ;normalize whats left, optimize ;to combine with just above code .endc .ifdf fpu f0=%0 .if ndf $basic ;add immediate to stack adf$is: ldf (sp)+,f0 clr -(sp) mov (r4)+,-(sp) addf (sp)+,f0 stf f0,-(sp) jmp @(r4)+ ;add argument to stack adf$ps: ldf (sp)+,f0 mov @(r4)+,r0 addf @r0,f0 stf f0,-(sp) jmp @(r4)+ ;add variable to stack adf$ms: ldf (sp)+,f0 addf @(r4)+,f0 stf f0,-(sp) jmp @(r4)+ .endc ;$basic ;add stack to stack $adr: adf$ss: ldf (sp)+,f0 addf (sp)+,f0 stf f0,-(sp) jmp @(r4)+ .if ndf $basic ;subtract immediate from stack suf$is: ldf (sp)+,f0 clr -(sp) mov (r4)+,-(sp) subf (sp)+,f0 stf f0,-(sp) jmp @(r4)+ ;subtract argument from stack suf$ps: ldf (sp)+,f0 mov @(r4)+,r0 subf @r0,f0 stf f0,-(sp) jmp @(r4)+ ;subtract variable from stack suf$ms: ldf (sp)+,f0 subf @(r4)+,f0 stf f0,-(sp) jmp @(r4)+ .endc ;$basic ;subtract stack from stack $sbr: suf$ss: ldf 4(sp),f0 subf (sp)+,f0 stf f0,@sp jmp @(r4)+ .endc .ifdf fis ;add immediate to stack adf$is: clr -(sp) mov (r4)+,-(sp) ;add stack to stack adf$ss: $adr: fadd sp jmp @(r4)+ .if ndf $basic ;add argument to stack adf$ps: mov @(r4)+,r1 br adfps ;add memory to stack adf$ms: mov (r4)+,r1 adfps: mov 2(r1),-(sp) mov @r1,-(sp) fadd sp jmp @(r4)+ ;subtract immediate from stack suf$is: clr -(sp) mov (r4)+,-(sp) .endc ;$basic ;subtract stack from stack suf$ss: $sbr: fsub sp jmp @(r4)+ .if ndf $basic ;subtract argument from stack suf$ps: mov @(r4)+,r1 br sufps ;subtract memory from stack suf$ms: mov (r4)+,r1 sufps: mov 2(r1),-(sp) mov @r1,-(sp) fsub sp jmp @(r4)+ .endc ;$basic .endc .end gument to stack adf$ps: mov @(r4)+,r1 br adfps ;add memory to stack adf$ms: mov (r4)+,r1 adfps: mov 2(r1),-(sp) mov @r1,-(sp) fadd sp jmp @(r4)+ ;subtract immediate from stack suf$is: clr -(sp) mov (r4)+,-(sp) .endc ;$basic .title fdiv floating divides ; h.j. , r.l. .globl $dvr .if ndf $basic .globl dif$is,dif$ss,dif$ms,dif$ps errdef .endc ;$basic .ifndf eae&muldiv&fis&fpu ;these routines support floating dividy ;$dvr is contained in this module ;dividy argument and stack .ifndf $basic dif$ps: mov @(r4)+,r1 ;get address of variable br difps ;branch into memory stack code ;dividy variable and stack dif$ms: mov (r4)+,r1 ;get address of variable difps: mov (r1)+,r0 ;get high order mov @r1,r1 ;get low part br fdiv ;branch to floating dividy ;dividy immediate value and stack dif$is: clr -(sp) ;clear low order mov (r4)+,-(sp) ;put high order on stack and fall thru .endc ;$basic ;dividy stack and stack $dvr: dif$ss: mov (sp)+,r0 ;get high order mov (sp)+,r1 ;get low order ;floating divide routine, yields 24 bits of significance fdiv: mov (sp)+,r2 ;get oprnd 2 mov @sp,r3 mov r4,@sp ;save some work regs mov r5,-(sp) asl r0 ;get sign from denominator beq zrodiv ;x/0. is an error rol -(sp) ;save sign asl r2 ;get sign from numerator beq zero ;0./x gives 0. result adc @sp ;xors signs in low bit to give final mov r2,r4 ;make copy of numerator clrb r2 ;isolate exp bic r2,r4 ;remove exp from copy mov r0,r5 ;make copy of high denominator clrb r0 ;isolate exp bic r0,r5 ;remove exp from copy ; r5:r1 will be denominator right justified ; r4:r3 will be numerator right justified ; r0 contains partial quotient ; r2 is semi free sub r0,r2 ;take difference in exp+128 bcs 1$ ;branch if 777>final exp>400 bpl 2$ ;branch if 577>exp>400, its good error fovrfl ;floating divide overflow br zero ;set result to 0 to continue 1$: bpl funder ;branch if 0denom bhi 3$ ;branch if num bigger blo 4$ ;branch if denom bigger cmp r3,r1 ;check low parts if high equal blo 4$ ;branch if denom bigger beq same ;r0 fortituously contains a 400 here ;which is exactly what we want to add ;to the exponent in this case - done! 3$: sub r1,r3 ;reduce num by denom and sbc r4 ;-produce only 7 bits sub r5,r4 ;-of quotient adjusting exp for mov #1002,r0 ;-initial success 4$: mov #nxt16,-(sp) ;return to nxt16 after first 8 in loop divide: asl r3 ;get bit from low num rolb r4 ;shift into high bcs 1$ ;branch if num definitly > denom cmpb r5,r4 ;see if num>denom bhi 2$ ;branch if denom bigger, c-bit=0 beq 3$ ;branch if equal to check low parts 1$: sub r1,r3 ;reduce num by denom sbc r4 sub r5,r4 sec ;set quotient bit to 1 2$: rol r0 ;shift quotient bcc divide ;continue until guard digit plops into c rts pc ;return 3$: cmp r1,r3 ;see if low parts equal bhi 2$ ;branch if denom>num, c-bit=0 blo 1$ ;branch if num>denom sec ;numbers are same, set 1 last quo bit 4$: rol r0 ;normalize quotient bcc 4$ ;branch until guard bit comes up cmp (sp)+,#round ;is this first 8 bits of result? beq end ;branch if not same: add r0,r2 ;form high word of result clrr0: clr r0 ;low word =0 br end ;go finish up nxt16: add r0,r2 ;form high word of result mov #1,r0 ;set for 16 bits more jsr pc,divide ;** this must be just before "round" ** round: asr r5 ;halve denominator for rounding cmpb r5,r4 ;now that 24 bits are done is num>den/2 adc r0 ;c-bit set if num>denom adc r2 end: mov (sp)+,r5 ;restore regs mov @sp,r4 mov r0,@sp ;put result on stack mov r2,-(sp) jmp @(r4)+ ;leave funder: error fundfl ;floating divide underflow zero: tst (sp)+ ;adjust stack, gets rid of sign zerox: clr r2 ;clear result br clrr0 ;go to end after clearing r0 zrodiv: error fzdiv ;floating divide by 0. br zerox ;set result to 0. .endc .ifdf eae!muldiv .ifndf fis ;these routines support floating divide ;$dvr is contained in this module ;divide argument and stack .ifndf $basic dif$ps: mov @(r4)+,r1 ;get address of variable br difps ;branch into memory stack code ;divide variable and stack dif$ms: mov (r4)+,r1 ;get address of variable difps: mov 2(r1),-(sp) ;get high order mov @r1,-(sp) ;get low part br $dvr ;branch to floating divide ;divide immediate value and stack dif$is: clr -(sp) ;clear low order mov (r4)+,-(sp) ;put high order on stack and fall thru ;divide stack and stack .endc ;$basic $dvr: dif$ss: mq=177304 nor=177312 lsh=177314 ash=177316 d=8. n=12. q=12. mov r4,-(sp) mov r5,-(sp) clr r0 clr r1 clr -(sp) asl n+0-2(sp) ;shift numerator rol @sp ;get numerator sign clr -(sp) tst d(sp) ;check for 0.0 denominator beq dchk bisb n+1(sp),@sp ;get numerator exponent beq zero ;jump if numerator is zero bisb n(sp),r0 swab r0 ;left justify numerator fraction sec ;insert normal bit ror r0 bisb n+3(sp),r0 bisb n+2(sp),r1 swab r1 clr r2 clr r3 asl d(sp) ;shift denominator adc 2(sp) ;get result sign bisb d+1(sp),r2 ;get divisor exponent sub r2,@sp ;subtract exponents clr r2 bisb d(sp),r2 ;get high order fraction swab r2 sec ;insert normal bit ror r2 bisb d+3(sp),r2 bisb d+2(sp),r3 swab r3 clc ;ensure num. and denom. + ror r0 ror r1 ;low order r1 and r3 are 0 ror r2 ror r3 cmp r0,r2 ;compare high numerator and denominator blo dhi ;jump if denominator high bhis dlow ;jump if denominator low or same zero: cmp (sp)+,(sp)+ ;flush exp and sign br ecall1 dchk: tst (sp)+ ;flush exp error fzdiv ;issue error br ecall over1: tst -(sp) ;fake sign over: error fovrfl ;issue error br ecall under: error fundfl ;issue error ecall: tst (sp)+ ;flush sign ecall1: clr q+0-4(sp) ;return 0 clr q+2-4(sp) br rtn dlow: ror r0 ;halve numerator (c=0) ror r1 ;to ensure that n2^(n-1)-1+(2^(n-2)-1)+... swab r1 ;left justify shifter swab r0 ;it makes loop faster clrb r0 bisb r1,r0 clrb r1 mov r2,r4 ;r2:r3 will be sum, r4:r5 will be addin mov r3,r5 loop: asr r4 ;shift addin right ror r5 asl r1 ;shift multiplier left beq 1$ ;see if were done rol r0 ;shift out 1 bit bcc loop ;dont add, bit was 0 2$: add r5,r3 ;form sum adc r2 add r4,r2 br loop ;go until multiplier 0 1$: rol r0 ;shift last bit of r1 in bcc 5$ ;dont add if no bit 4$: add r5,r3 ;form sum adc r2 add r4,r2 5$: asr r4 ;shift addin right ror r5 asl r0 ;comes here if low word 0 to finish up bcs 4$ ;bit was 1 so add bne 5$ ;bits still left so continue tst r2 ;not needed if round by .3 or .6 ok bmi 3$ ;branch if result is norm'ed ok rol r3 ;norm it left 1 bit rol r2 sub #200,@sp ;sub 1 from exp because left shift 3$: rolb r3 ;get bit to round by in carry rol r1 ;put in r1 which had to be 0 clrb r3 ;get rid of extra precision bisb r2,r3 ;get result back into right 3 bytes swab r3 clrb r2 swab r2 add (sp)+,r2 ;put sign and exp into result add r1,r3 ;round low order adc r2 ;round high order out: mov (sp)+,r5 ;restore regs mov (sp)+,r4 mov r3,-(sp) ;put result on stack mov r2,-(sp) jmp @(r4)+ ;leave .endc .ifdf eae!muldiv .ifndf fis ;these routines support floating multiply ;$mlr is contained in this module ;multiply argument and stack .ifndf $basic muf$ps: mov @(r4)+,r1 ;get address of variable br mufps ;branch into memory stack code ;multiply variable and stack muf$ms: mov (r4)+,r1 ;get address of variable mufps: mov 2(r1),-(sp) ;get high order mov @r1,-(sp) ;get low part br $mlr ;branch to floating multiply ;multiply immediate value and stack muf$is: clr -(sp) ;clear low order mov (r4)+,-(sp) ;put high order on stack and fall thru .endc ;$basic ;multiply stack and stack $mlr: muf$ss: mq=177304 sr=177311 lsh=177314 a=8. b=12. reslt=8. sign=2 mov r4,-(sp) mov r5,-(sp) ; eae code .ifdf eae ; (a1+a2*2**-16)*(b1+b2*2**-16) mov #mq,r4 ;point to mq mov #100000,r5 ;get leading bit mov b+2-4(sp),@r4 ;low order b to mq mov b+0-4(sp),-(r4) ;high to ac beq zero ;jump if 0 inc @#lsh ;get sign rorb @#sr rol -(sp) ;save it mov (r4)+,-(sp) ;save exponent clrb @sp ;right justify it swab @sp mov #7,@#lsh ;move fraction left mov @r4,-(sp) ;save b2 bis r5,-(r4) ;insert normal bit mov (r4)+,-(sp) ;save b1 mov a+2+4(sp),@r4 ;low order a to mq mov a+0+4(sp),-(r4) ;high to ac beq zero2 ;jump if 0 inc @#lsh ;get sign rorb @#sr adc 6(sp) ;get result sign mov @r4,r3 ;get exponent clrb r3 swab r3 add r3,4(sp) ;get sum of exponents mov #7,@#lsh ;left justify fraction mov (r4)+,r2 ;save a1 bis r5,r2 ;insert normal bit clr r0 ;clear product clr r1 mov (r4)+,r3 ;save a2 bne a2nz tst -(r4) ;point to mq br a2z ;short cut a2nz: mov @sp,@r4 ;get b1*a2 cmp -(r4),-(r4) ;point to ac add r3,@r4 ;a2. 2's comp correction tst r3 bpl a2p add @sp,@r4 ;b1. correction a2p: mov (r4)+,r1 ;high product to r1 a2z: mov 2(sp),(r4)+ ;b2 to mq bne b2nz tst -(r4) ;point to mq br b2z ;short cut b2nz: mov r2,@r4 ;get b2*a1 cmp -(r4),-(r4) ;point to ac add 2(sp),@r4 ;b2. correction tst 2(sp) bpl b2p ;jump if b2 + add r2,@r4 ;a1. correction b2p: add (r4)+,r1 ;high product to r1 adc r0 b2z: mov r2,(r4)+ ;a1 to mq add r2,r0 mov @sp,@r4 ;get a1*b1 add (sp)+,r0 add -(r4),r1 adc r0 add -(r4),r0 ;ac+r0 tst (sp)+ ;pop b2 mov (sp)+,r4 ;get sum of exponents .endc ; mul/div code .ifdf muldiv ; (a1+a2*2**-16)*(b1+b2*2**-16) mov b+2-4(sp),r5 ;low order b mov b+0-4(sp),r4 ;high order beq zero .word 073427,1 ;; ashc #1,r4 ;get sign bit rol -(sp) ;save it mov r4,-(sp) ;save exponent clrb @sp swab @sp ;right justify .word 073427,7 ;; ashc #7,r4 ;left justify fraction mov r5,-(sp) ;save b2 bis #100000,r4 ;insert normal bit mov r4,-(sp) ;save b1 mov a+2+4(sp),r3 ;get a2 mov a+0+4(sp),r2 ;get a1 beq zero2 ;jump if result to be 0 .word 073227,1 ;; ashc #1,r2 ;get sign adc 6(sp) ;get result sign mov r2,r0 ;get exponent clrb r0 swab r0 add r0,4(sp) ;get sum of exponents .word 073227,7 ;; ashc #7,r2 ;get a1 bis #100000,r2 ;insert normal bit clr r0 ;clear accumulator clr r1 tst r3 ;check a2 beq a2z ;jump if 0 .word 070403 ; ;mul r3,r4;get a2*b1 add r3,r4 tst r3 bpl a2p ;jump if a2 + add @sp,r4 ;b1 correction a2p: mov r4,r1 ;a2*b1*2**-16 a2z: mov 2(sp),r4 ;b2 to multiplier beq b2z ;jump if 0 .word 070402 ; ;mul r2,r4;get a1*b2 add 2(sp),r4 tst 2(sp) bpl b2p ;jump if b2 + add r2,r4 ;a1 correction b2p: add r4,r1 ;a1*b2*2**-16 adc r0 b2z: mov r2,r4 ;a1 to multiplier add r2,r0 .word 070416 ; ;mul @sp,r4;get a1*b1 add (sp)+,r0 add r5,r1 ;low order a1*b1 adc r0 add r4,r0 ;high order a1*b1 tst (sp)+ ;pop b2 mov (sp)+,r4 ;get sum of exponents .endc rol r1 ;shift out normal bit rol r0 bcs norm ;jump if it was found rol r1 rol r0 ;must have got it now dec r4 ;adjust exponent norm: sub #200,r4 ;take out one of the excess 128's ble under ;jump if underflow cmp #377,r4 blt over ;jump if overflow clrb r1 bisb r0,r1 swab r1 clrb r0 bisb r4,r0 swab r0 ror (sp)+ ;get product sign ror r0 ;insert it in result ror r1 adc r1 adc r0 bcs over1 ;jump if overflow on round bvs over1 out: mov r0,reslt(sp) ;put out answer mov r1,reslt+2(sp) mov (sp)+,r5 mov (sp)+,r4 cmp (sp)+,(sp)+ ;flush top argument jmp @(r4)+ ;return zero2: cmp (sp)+,(sp)+ ;pop b1,b2 zero1: cmp (sp)+,(sp)+ ;pop sign and exponent br zero over: tst (sp)+ ;flush sign over1: error fovrfl br ecall under: error fundfl tst (sp)+ ;flush sign ecall: zero: clr r0 ;clear result clr r1 br out .endc .endc .ifdf fis ;these routines support floating multiply ;$mlr is contained in this module ;multiply argument and stack .if ndf $basic muf$ps: mov @(r4)+,r1 ;get address of variable br mufps ;branch into memory stack code ;multiply variable and stack muf$ms: mov (r4)+,r1 ;get address of variable mufps: mov 2(r1),-(sp) ;get high order mov @r1,-(sp) ;get low part br $mlr ;branch to floating multiply ;multiply immediate value and stack muf$is: clr -(sp) ;clear low order mov (r4)+,-(sp) ;put high order on stack and fall thru .endc ;$basic ;multiply stack and stack $mlr: muf$ss: fmul sp jmp @(r4)+ .endc .ifdf fpu f0=%0 .if ndf $basic muf$ms: ldf @(r4)+,f0 ;load up op1 br mul muf$ps: mov @(r4)+,r0 ;get address of item into r0 ldf @r0,f0 ;get item br mul muf$is: clr -(sp) ;set up immediate item mov (r4)+,-(sp) ;put in high part .endc ;$basic muf$ss: $mlr: ldf (sp)+,f0 ;get multiplicand mul: mulf (sp)+,f0 ;multiply stf f0,-(sp) ;product to stack jmp @(r4)+ .endc .end t high order on stack and fall thru .endc ;$basic ;multiply stack and stack $mlr: muf$ss: fmul sp jmp @(r4)+ .endc .ifdf fpu f0=%0 .if ndf $basic muf$ms: ldf @(r4)+,fmacro p3.mat intr.mat macro p3.mat conv3.mat macro p3.mat fadd.mat macro p3.mat fmul.mat macro p3.mat conv2.mat macro p3.mat fdiv.mat macro p3.mat exp.mat macro p3.mat sqrt.mat macro p3.mat atan.mat macro p3.mat alog.mat macro p3.mat sin.mat macro p3.mat ermod.mat multiply stf f0,-(sp) ;product to stack jmp @(r4)+ .endc .end t high order on stack and fall thru .endc ;$basic ;multiply stack and stack $mlr: muf$ss: fmul sp jmp @(r4)+ .endc .ifdf fpu f0=%0 .if ndf $basic muf$ms: ldf @(r4)+,f .title intr --real number truncater .globl $intr,$popr3,$ervec,$polsh $intr: .ifndf fpu clr r2 mov (sp)+,r0 mov (sp)+,r1 mov r0,r3 rol r3 clrb r3 swab r3 sub #230,r3 bge 4$ cmp #-30,r3 blt 1$ clr r0 clr r1 br 4$ 1$: mov r3,-(sp) .ifndf eae&muldiv 2$: ror r0 ror r1 inc r3 blt 2$ mov (sp)+,r3 3$: asl r1 rol r0 inc r3 blt 3$ .endc .ifdf eae mov #mq,r3 mov r1,@r3 mov r0,-(r3) mov @sp,@#lsh neg @sp mov (sp)+,@#lsh mov (r3)+,r0 mov @r3,r1 .endc .ifdf muldiv .word 073016 neg @sp .word 073026 .endc 4$: tst r2 beq 5$ rts r5 5$: mov r1,-(sp) mov r0,-(sp) jmp @(r4)+ .endc .ifdf fpu .word 170001 .word 172426 .word 171467,4 .word 174146 jmp @(r4)+ .word 040200,0 .endc $popr3: mov (sp)+,r0 mov (sp)+,r1 jmp @(r4)+ $polsh: tst (sp)+ jmp @(r4)+ .end mov (sp)+,r3 3$: asl r1 rol r0 inc r3 blt 3$ .endc .ifdf eae mov #mq,r3 mov r1,@r3 mov r0,-(r3) mov @sp,@#lsh neg @sp mov (sp)+,@#lsh mov (r3)+,r0 mov @r3,r1 .endc .ifdf muldiv .word"!@? @  l0 &   rC d  A?? A  (   A    $  JC  A . T?;T?7N? W-7@AWn Waew*AC *J@ F @ 8 B 7BAD SWITCH @@@ @ a z  : @ .C :  t 7`>>?z@wP |@ r@t>2>@ 2J@l 7b> T@  6 v B 8@ x > >*>*>">> 4 H  ?*  ?$ ~X>CP> V@F>n@Cы r C 2FB ?C& P ./ @  Ћ.2@PR C "A 4 C l ^7SYMBOL TABLE OVERFLOW >@ :B :B .B d.BE5     ?U&f   C< e C z7>Un>? z< 6<8< W- 0.>@ x:B :B >@5.B  .B B=B7P< 4ȋ `7 ><t@7 > U.BU.B0J@:B8 >@&f7J@;7 ;0J@:BFBh@U.B9>@U.B&f5.B0J@>@& V@e!&@`& B`@  1U 7j;wd;FBb@U.B: >@J@:B5.B &FB0 .B8 >@ 0 .B F?  5<p> F f>M EJ  -V>E  F>7 D>->>E h .> >+ > ѭ: BC : CW  & CjFvCUU 7 PF =w =d= wPF rpf rWtf /==@@h :W"n :~@i=@@h  rҕ-S= e ҕ-ҕ7ҝ:=ҕ & refW ҕ0 .ҕ: r<W ҕ0  !93!9 = C7~C  !8!83!8 7 C wC  C 4 W! C-N=hIz(fatal error-- too many modules to check lW! we~< t< r<ʝ8B\J    K (:e":-:: > W! n@ z v9 Z >QW DW!  <@ z? K j d5W!W! W! 5~9h5 $A RW!  m^9wX9w> r5 n5 wbD e@B Ì!  w9 xw8  jA e@= x! Xw8w DILLEGAL TEXT TYPE m89 r58w DUNDEFINED SYMBOL:#m8{8 Tl 0DDJb n> j> m>8RċR "8-7 8 8( 8%&f77 ^pD K  G~  r 7 7 < j3 377 & @3@3 x fD ! D! 7756 Q Q50B  jIlI/ 5<7 w > DUNDEFINED SYMBOLw ; 7 ;7  l5  7 65 6 65  hLa5 \La5 65 6 5 E6 B  "ŌZ DDwb  N$.8< < D S D  w J DPSECT MISSINGw ; 7 :"66m6 D6m6 L  L t  4 N d ejIx 5 c5m 5 F@pM 8 Ar L C S f5. ^5+&f7 T5(5&5  KpD W J ~ 5Wp J  7 4 5{ 4x&f44 L tifpDJ  `w4 Bw4 Lf Ff .w4pD vzD5 ~45 . b:@a j l d4=0 5 P4 L4U@rD (pc "sp פrע0ע5 5U454  7 ;7 ;$K; W! w ILLEGAL FORMAT jf dv X l;p$K , ^;\;w CHKSUM f U  ,;(; $;; / * .0wa; 0 89 7ҕ D ҕ D  7 ) --ҕ "ҕ D55 m3- 5 ҕ'A ^ҕ DՇ FT-R- p7 .-& b-^-7 Z) H;-J-D) 2I6)!-0--23J"=) -5- 7 ) ,,pD 7 ,7 ,5,,,!,5 ,m2,2,5,U, 0 Zb,`, !pD VH, p J  8!pD 60, p J 7 ,8,e *,w $,e +w + 2C C 7&2 $2 72 2w^ 21 +Wp zJ ` `J` CChqh C `7 '7 'V)@lJd'`'b@wf ( {+ 1.v+*-r+"3 X1@a ' )p1w &JF+tEJ8+lJ` ѝ"+ ѝ+w<1 wa++2(1&d&&] (Z(11 1 1.00 &C &@&& 00& &t WtEB`@ V~E H"&B&(&:&b@#7`0w 0-0d&-~0\& t0R&p0N& "%\0J%w%b@'7 &&@t &&@ 8)&fD&&&&CA ҕ  K ҕ APP 0ҕ @&&  %ҕ R0C ,C (D E/ / &// ĝ/7 /  "  5 *5 X5 J w (   z \  w w * B     $ DDDD#@#@0@#V$eP$EJ$ C @ @` E   #1-Q$) $``B ! #`B #` B #1-` w#7# sz%  ~ h#7 # ^~# |#@`@ @n#B b#w@ R~@@ ~ u@5@7"# f#A@B@C@D fAʕ RfA  eʕ Jҋ ~ rf e0R&D@ ( @ !D r  e ee e  ,,D! ! W" -- 8 ` &   %& e x@4" $ A @ V  C0  Bp` &ew%,,  + " +ş+f6  RRRRRRRRRRRRRRRRR⋇B  ^L ! !  "@ҕLҕNҕKҕEҕX * t*K  ^L$$D$ws,w p,B"U56"e7+ZL  ^L JBCB$ C/bin/print6$ end of passerrors detected: not found - can't create P*Pm11lstobjsmlxrf /bin/macxrfmmnmmmnmmmnjanfebmaraprmayjunjulaugsepoctnovdecoutobjmap/sys/ddt/bin/ddt/sys/ddt/bin/shareddt/sys/ddt/bin/odt>dr 0 > d j 2  $  \    (  F T T T T !!!!.macro.globlAJAJ`    @@@@@@@@@@@@@@@@@@@@@@@@@@NOVNS\XSbLSLPCRD2O2P2S2P1DDSD$OD,CCZE2BT^Lc000-xxx-00 00:00:00macro v1AUG75 VBB>CrCXBB@CtC"" **********module section address sizetransfer address: low limit: high limit: ^Lc000-xxx-00 00:00:00macro v1AUG75 VBB>CrCXBB@CtC"" 59@? @  +v,&   >C 0  A?? A b  ,Z,  A  l  j,d, A  ^?/^?7X? W-7LAD E@ : @ , C <7BAD SWITCH A a z  : @ B f   t 7`>>0?z@wL @ @>2>@ 2J@l,7> @  6  DB h@ r x 'X>X>P>L> . )  .@*  &@$ ~>D~> V@t>n@Dы ,D 2FB ?D& P ./ @  Ћ.2@P,D f)A ' D  7SYMBOL TABLE OVERFLOW >@ :B :B .B b.BE5     2?U&f   D = ,D w7>U>? < j<l< W- 0.>@,x:B :B >@5.B  .B B">B7< :ȋ f7 r<t@7>> U.BU.B0J@:B8 >@&f7J@$<7, <0J@:BFBh@U.B9>@U.B&f5.B0J@>@& V@e!&@`& B`@  1U 7;w;FBb@U.B: >@J@:B5.B &FB0 .B8 >@ 0 .B >  5=> 4A >M @J l& ->@  z>7 x>-r>n@ h b> ^@+,J> ѭ ; , BC $ CW  & C@@UU 7 @ =w =d= wPF rpf rWtf,/==@@hT:W"n J:~@=@@h  $ҕ-= e- %ҕ-ҕ7ҝn=ҕ & refW ҕ0 #ҕ: r<W ҕ0 #D- ET      6% !   ( > ! :7 9 7 > r w( ~$ Z$  %   L ?  ]?@ J$ f & ˵@'5 &m>U  ($ D 5@O>5  ~ U   @ m.> U5> ԋ 5  U  ҕ ҐҐ zE  n 퇇 7 |8C = C 9Y 7C C  & ,8 -8Ea Eɕ <=ɕ7 7E \ b5@*=5"=ŭ=E=U=Ew- X vL eee.8*8 6"8  |W!LW!H e Bҕ  V2 ERRRR 7ҝ7 E ѝ7@  $ 77  W!aW!z - w lDL x~ b7 ^7 6lDtD! W dDA85%+%- 5 VW!0W!95 5  \ 0bab b b m44 %.w 4܁%E  6 6 67`4@@T@T@Th 41"3 4 e4 4 4   5  P4 J4 F4 e:454w : b(J  5r56  UlDr lD  w m37 R57 5L5745 w" 0 3 B $  4 $ la      b b b    >47`447 47 47 4 27 4 &5 h4 D 5v44E5 -E3W! W!` #W!z 5F4e R 4Ew  W! W! )W! W! W! W!w W1 W1  4m3 4 Dww | 3  32n253723wl ݵ3& e mp.7373 %, Jx3 4563w47 4w )d3`3 p fFW"* ! ! b3\3C X3 N3 7 H3F  52 373U3w   * 2 2 Iw d C x p    52@  C BW!&W!!B  C 27 2 ~2Ev2J2"w  & 5 2  H2(2F2E@27 >2EEEE 7 ,.w 00/O1 h2(΋H5^2  ~1:5r11J25d1D<2,5P1E$2=D12$ "541AD |ҕ ҕ R1  1D D14E1 0E?1D %D50R|F D D FD " DEH H50 d0ҕ 0D DX1 7p0D e0b0?>1 ^+ D5$N0  07 070D "0 D z0ҕ 7 p05 0EH H5/  Dʕ Dҕ |F5/  Dҕ F5/ ҕ  *  *5r0,* 5?ʕ'5@ʕGҋ<0E :.gAы7 &0R@   7x/7 v/** wU/ Lw 7T-J/P- 8Eҕ  J W! U ҋ ҕ "@ "@ ^.F , R6  MF5 .+.(~A  t .. -.    r e0J w w  T Cw    V rC!wC  .( .  b  B ~ .P-0-@-0 `- P-w z -Uj. -'s-'s|- t-7 r-7 p--H.@C.->.-8.@3.-..AF :-V5@*-R7 -7 "(D (5R- - |E5 pA < `Eɥa fҕ Dև 27 ' ( ( ҕ E ҕ E ( D &D 4,p, h, (`,\, jĝR,7 N, D/ <,, ,)<,+ j*A rT,  r,ҕ-h,  8E F A  "  5 E5 5 +- ^ W! ww+UJ, wn+r+ C -b+b+  H+7 D+ 5A E "&  & & R H     E $*e7 8+ww   ****  ~ X&   $  p+*U@T+   7 *-**w 6  T @ & $7R*7T*&  .**  6@*  @ V ) l @  *&  >ww  7 *7 ) %?S) v  `   7 T* & #-x)D*& z  p) %\0 4  \):  0  F) *   E E 5( )7)U)  f) 8 T 0),)e?f $ . ( rf e0w  U@J) 5  %(  )5W!(  0 l W!) " D\( * P    # "(  (  ~ v W!' n $ '  *'! $      Eff  7 ''ww N''w >  L J w ( 6t'  @B     C w 6 <   E<>C!W!^8.  C D C!D! Uw b'RFP: 7J'D' x H 7& p 7,' &f' 7 x&5 RZ&>!e8!7H&   & (&$& EfR %ER &E   @  %U@&-W!(BNW *B ɟ%ŀW)! x ! h- #' $  ~5E % % H  r  t %w 7 %7 r%w    % % `@Z@0@HeE C @ @` E   #1-Q$) ``B ! #`B Z` B #1-` w472 s+%  ~ h7  ^ @`@ @B w@ R~@@ ~ u@5@7 fA@B@C@E #]#@ W!:fW!=wZ < ! w |#|# W!$ & W!: z##5w  D .5E H  5U#  . 0. W!= W!:  " -" >  " vW!:@" fW!*U" V5 "EU ]t" P"5-"ʭ"w U  w L""7 6"w W!=@"" W!*U" Eff 5 "% t 5"U& EUw"" ]! !7!w d@ 7 !Ew\" E55 w 6 &  5 0"]Z7 ~!7 |!w E & f-A-f < E !!  1P@E%P%E% 5E%pE%E%% A A 5w h@ 5w VE ^    w .E x& R5`5  hU!  x   z  0w @  & W!@   w UW!#  U[W!-  vW!( U SW!( W!+ RUF5U@ 5 . W!(53 5@\5@m5FUU7 5w Effff PU0 U  :W!)ww  w   5U@ t w P  V  EE  ~zX  ( XUP UUP EE <  j ( UPE&& pÝ  :w  R7 7 (5 EE   wV  Z ` EU  2  w 7w  0"  ` BW!<% @B!  E H 4 .w  & # &    (w P& e  W   6 C L | Pb0\@T PLX w o47 2  $7 jw 7 7  @.  5 w - >. w z  ~7 ~vEfAʕ RfA  eʕ Jҋ ~ rf e0R&E@ ( @ !E r  e ee e  E! ! W. -- 8 ` &   & e x@4. $ A @ V  C0  Bp` &ew^JF  @ . .ş*f6  RRRRRRRRRRRRRRRRR⋇B  FwA l E  FwU5e7^fF  F ,JBDBj,D/bin/print"|end of passerrors detected: not found - can't create P*Pm11lstobjsmlxrf/bin/macxrfmmnmmmnmmmnjanfebmaraprmayjunjulaugsepoctnovdec0uXuuuuu@yxd + -@ *V /6 &< !t + - " ' %<^C&D*O.BDFLP  =% r g @/sys/maclnk/bin/sysmac++%+%%%+(%+%%T%+%%%%%%%+%%%%%+%%   @@@@@@@@@@@@@@@@@@@@@@@@@@NO(NS.XS4LS\LPXCR|LINLFL ENN)DSL)%@  @@`@%@@ @t@ @vD D J J Y    v @@ @ @P @ 0 eoovt P;  %  % %@ % @  ~@r~@~%@\!42}s: s: :@@AK@K &@K8@K09@KK@KK@K@K@K@Kf@KK zQD @R@@R@8@ S@S%@S@S @pTpT@8 T@pT@T%@OX OX OXOX%Y[q`"r@ r @r r sssw w ;wwww w%w@8wK wwy~Lyyyy@yh@y@y &@y&@y`'@y@y@y@yfyy} z@ z@ z%@Yz z d @ %@}j@x;1(;B((;R'\E<(\XH:(i}((h'L)֯N)֯,'֯x֯֯ׯ}\(گr^ޯp!P(0P0$^&l!nntn!tn%n+tn,tn.tnKtnKtn Ntn&XtnHXtn[tn}n}ntq%Bzdzxd鰼R0y   , |,1q34CrCXBB@CtC&A.@AA.fA. AAA5 3f: (+xK+M r+I+ke+@(!HX[."K#+" N*,+K*2&X3 <W=8RnS ABEILMNOPQRTUZ.main.table of contents******symbol table page w[M y%` QQR RK-[zTq  ,@K@Ba&xf:<F]000-xxx-00 00:00:00macro v7MAR75 ,,,,,,VBB>CrCXBB@CtC&A.@AA.fA. AAA5.ar .bp 1 .sp 4 .ce 1 BUILDING UNIX BASIC .he 'Building UNIX BASIC''Version 3-f' .fo ''-%-'' .hy 0 .pn .sp 3 .ti +5 This document is intended for use by system programmers building a copy of BASIC for use under the UNIX operating system. The BASIC described is a variant of DEC RT-11 BASIC, which was modified in July 1974 at Harvard University. .ti +5 The files required for UNIX BASIC version 3-f come in three packages: command files for use in building the system; the BASIC interpereter; and the BASIC floating point math package. They are: .sp 2 .in 5 Command files-- .ti -5 assem -- assembles the BASIC interpereter. .ti -5 fpassem -- assembles the floating point math package. .ti -5 link -- links the object files produced by the above command files to produce a shareable copy of BASIC. .ti -5 plink -- links the object files with DDT or ODT to produce an unshareable copy of BASIC for debugging. .sp 2 BASIC Interpereter files-- .ti -5 p1.mac -- macro definitions, system assembly constants, and global variable definitions. .ti -5 p2.mac -- system constants, globals, and token definitions. .ti -5 r.mac -- root segment: execution dispatch and data management routines. .ti -5 e.mac -- edit segment: lexer, parser, and editor. .ti -5 x.mac -- execution segment: commannd execution routines. .ti -5 s.mac -- I/O and resident utility routines. .ti -5 i.mac -- assembly language routine interface module (CALL statement). .ti -5 h1.mac, h2.mac, h3.mac -- once-only initialization code. .ti -5 matpak.mac -- matrix manipulation commands. .sp 2 Floating Point package-- .ti -5 p3.mat -- parameter definitions for assembly without hardware floating point. .ti -5 p3.fpu -- parameters for hardware floating point. .ti -5 ermod.mat - floating point error handler. .ti -5 conv2.mat, conv3.mat - integer/floating conversion. .ti -5 intr.mat -- floating truncation. .ti -5 fadd.mat -- floating addition. .ti -5 fmul.mat -- floating multiplication. .ti -5 fdiv.mat -- floating division. .ti -5 exp.mat -- exponential function. .ti -5 sin.mat -- sine and cosine functions. .ti -5 sqrt.mat -- square root function. .ti -5 alog.mat -- natural and common logarithm functions. .ti -5 atan.mat -- arctangent function. .in 0 .sp 2 .ti +5 These files must be assembled with Harvard MACRO-11 and linked with Harvard LINKR. All ASCII strings must be assembled in lower case. After completion of the command sequence: .br % sh assem .br % sh fpassem .br % sh link .br an executable file "basic" resides in the current directory (execution of plink produces "pbasic"), which may be run in the normal fashion. .ti +5 If an installation finds it necessary to reduce the size of UNIX BASIC, several parameters may be changed in p1.mac to eliminate certain features. These include: .in 5 .sp 1 .ti -3 $reseq -- if undefined, eliminates code for the RESEQuence statement. .ti -3 $ext -- if undefined, eliminates code for the EXTEND statement, which, in version 3-f, includes statements for producing protocols of BASIC sessions, for unlinking files, and typing update news. .ti -3 $deflo -- the default size for the BASIC loseg. See "USING UNIX BASIC" for an explanation of how each user may increase his area. Must be an integer in the range 2-31. .ti -3 protec -- the protection code given to files created with BASIC. Currently ^O644 (rw-r--r--). .ti -3 $nopru -- if defined, eliminates code for the PRINTUSING statement. .ti -3 $longer -- if defined, produces long error messages (about three words) instead of the usual three-letter messages. .ti -3 $ulnsp -- the maximum number of characters in a BASIC line. Must be even. .ti -3 $pnamsz -- the maximum number of characters in a file pathname. .ti -3 $sysfn -- if undefined, eliminates code for the SYS function, which, in version 3-f, includes a function to substitute characters in a string without making garbage copies, and an exit to DDT or ODT for debugging. .ti -3 $nostr -- if defined, the BASIC produced will not support string variables or string operations. .ti -3 $stksz, $stkex -- arbitrary parameters which determine the amount of stack which BASIC thinks it has. Since BASIC uses the UNIX stack, no space is saved by decreasing these parameters. The default value (^O200 for $stksz and ^O50 for $stkex) is generally sufficient, even for complex programs. .ti -3 $novf -- if defined, eliminates code which supports virtual files. .ti -3 $maxun -- the maximum I/O unit number, i.e. the maximum local value of n in the statements "PRINT #n" and "VFn". Should be left at 5 for unix systems. .ti -3 $bufsz -- the size of the I/O buffers. Must be even. If virtual files are supported, must be a power of 2 > ^D128. .in 0 .sp 1 .ti +5 The specifications for interfacing assembly language subroutines with BASIC for use via the CALL statement are given in reference 3) below. .ti +5 The EXTEND and SYS statements are as yet undocumented, since they will be changed in BASIC version 3-g. In 3-f, however, the EXTEND statement is of the form "EXTEND(n,args)" where n is a dispatch number which specifies what command is to be executed, and args are the arguments to the appropriate command. Commands supported are: .sp 1 .in 5 .ti -3 n=1 -- create a file "basic.protocol" in the current directory which will be a protocol of the BASIC session from the statement following "EXTEND(1)" up to the statement to terminate the protocolling. .ti -3 n=0 -- stop recording the session in the protocol file, and close that file. .ti -3 n=2 -- unlink the specified file from the specified directory. The single argument is a string expression which must evaluate to "pathname". No default extensions are appended. .ti -3 n=3 -- type the file /lib/basic/news.bas which is a summary of changes in the BASIC system from version to version. .sp 1 .in 0 The SYS functions are value- returning functions. They are of the form "SYS(n,args)" and dispatch numbers supported are: .sp 1 .in 5 .ti -3 n=0 -- string substitute function. Args are A$,B$,N,I where the effect is to substitute the characters B$ for characters in A$ beginning at character N, and leave I with the value 1 for a sucessful substitution or 0 for failure. Failure may occur if (LEN(A$)-N)-LEN(B$) <0 or if N >LEN(A$). .ti -3 n=1 -- exits to DDT or ODT with a continuable "bad entry". Returns a value of 1. If neither DDT nor ODT is loaded, produces an error message. .sp 1 .in 0 .ti +5 UNIX BASIC is still under development at Harvard. If users discover any inconsistencies or bugs, please send a description and minimal protocol to: .ti +10 John Burruss .ti +10 c/o Director's Office .ti +10 Science Center .ti +10 1 Oxford Street .ti +10 Harvard University .ti +10 Cambridge, MA 02138 .br Updates are in preparation. These will include, hopefully before the end of 1974, a Matrix function package and placing BASIC in I/D spaces to allow a larger user workspace. .ti +5 References which describe UNIX BASIC are: .in +5 .ti -2 1). BASIC-11 LANGUAGE REFERENCE MANUAL, DEC-11-LIBBA-A-D, 1974, Digital Equipment Corporation. .ti -2 2). USING UNIX BASIC, in HRSTS MATHEMATICAL LANGUAGES HANDBOOK, 1974, Harvard University. .ti -2 .in 0 Users planning to modify or extend UNIX BASIC will find useful information on format of data and symbol table in .in 5 .ti -2 3). BASIC/RT11 LANGUAGE REFERENCE MANUAL, DEC-11-LBACA-B-D, Digital Equipment Corporation. .in 0 r user workspace. .ti +5 References which describe UNIX BASIC are: .in +5 .ti -2 1). BASIC-11 LANGUAGE REFERENCE MANUAL, DEC-11-LIBBA-A-D, 1974, Digital Equipment Corporation. .ti -2 2). USING UNIX BASIC, in HRSTS MATHEMATICAL LANGUAGES HANDBOOK, 1974, Harvard University. .ti -2 .in 0 Users UNIX BASIC loseg map High Address +--------------------+ <--LIMIT(R5) ! GOSUB pointers ! ! 26 FN pointers ! ! READ pointer ! +--------------------+ <--ARRAYS(R5) ! ! ! ! ! ! ! arrays ! ! ! ! ! ! \!/ ! ! V ! <--HIFREE(R5) moveable +--------------------+ <--HISTR(R5) moveable ! strings ! +--------------------+ <--LOSTR(R5) moveable ! A ! <--LOFREE(R5) moveable ! /!\ ! ! ! ! ! ! ! ! symbols ! ! ! ! +--------------------+ <--SYMBOLS(R5) moveable ! A ! ! inter- /!\ ! ! pereted ! ! ! code ! ! ! ! ! ! ! +--------------------+ <--CODE(R5) ! user line buffer ! ! ! +--------------------+ <--LINE(R5) ! ! ! user area storage ! ! cells named above ! ! ! +--------------------+ <--R5 ! miscellaneous ! ! storage cells ! ! and ! ! tty i/o buffers ! +--------------------+ ! print program ! ! header ! ! subroutine ! +--------------------+ ! ! user area storage ! ! cells named above ! ! ! +--------------------+ <--R5 ! miscellaneous ! ! storage cells version 4a of basic accepts the following matrix statements: mat a=zer sets a to be all zeros mat a=con sets a to be all ones mat a=idn sets a to be an identity matrix mat print a,b,c prints matrices a,b,c on teletype mat b=a copies matrix a to b mat c=a+b c is result of adding matrices a,b mat c=a-b c is result of subtracting matrices a,b mat c=a*b c is result of multiplying matrices a,b mat input v inputs a vector v from teletype mat read a,b,c reads matrices a,b,c from data statements mat b=(k)*a b is a multiplied by scalar expression k mat b=trn(a) b is the transpose of a mat b=inv(a) b is the inverse of a matrices are normally dimensioned at the beginning of a program by means of the dimension statement, e.g. dimension a(3,5),b(10,10) an array which has not been previously dimensioned will automatically be given dimensions of 10 by 10 on its first appearance in a matrix statement. certain of the matrix statements allow a matrix to be redimensioned, provided the new dimensions require less elements in total than the old matrix, e.g. mat a=zer(2,2) mat a=con(3,3) mat a=idn(3,3) mat read a(2,4),b(3,2) other matrix statements may implicitly require redimensioning, as in the result of multiplication or taking the transpose. this redimensioning will occur automatically if the matrix is large enough to accomodate all necessary elements. more details: mat print will print in 14 space wide columns, lined up, if the matrices are separated with commas. if semicolons are used, the printout will be in packed format, with a minimum of space between elements. when mat input is used, entries may be continued on a new line if the preceding line is terminated with &. after mat input, the number of items entered may be obtained by calling the num() function. after mat inversion, the determinant of the original matrix may be obtained by calling the det() function. further information on the use of 'mat' statements in basic may be found in: dec pdp-10 mathematical languages handbook (section on basic) kemeny & kurtz, 'basic programming' ace between elements. when mat input is used, entries may be continued on a new line if the preceding line is terminated with &. after mat input, the number of items entered may be obtained by calling the num() function. after mat inversion, the determinant of the original matrix may be obtained by calling the det() function. further information on the use of 'mat' statements in basic may be found in: dec pdp-10 mathematical languages hvunix=1 $longer=1 fpu=1 .globl bombdon,msgerr,$fperr .macro .hiseg .psect hiseg con,shr .endm .macro finit r0=%0 r1=%1 r2=%2 r3=%3 r4=%4 r5=%5 sp=%6 pc=%7 .endm .globl error. $basic=1 lineno=30 .macro error a jsr r4,error. .word a .endm .macro ercon a,b jsr r1,msgerr .ifdf $longer .asciz "b" .iff .asciz "a" .endc .even .endm .macro errdef fovrfl=0 fundfl=2 fzdiv=4 ngsqrt=6 badlog=10 intov=12 .endm errdef f0=%0 f1=%1 f2=%2 f3=%3 f4=%4 .mcall $sig .hiseg dp-10 mathematical languages .nlist cnd cmunix=1 hvunix=1 $longer=1 muldiv=1 .globl bombdon,msgerr .macro .hiseg .psect hiseg con,shr .endm .macro finit r0=%0 r1=%1 r2=%2 r3=%3 r4=%4 r5=%5 sp=%6 pc=%7 .endm .globl error. $basic=1 lineno=30 .macro error a jsr r4,error. .word a .endm .macro ercon a,b jsr r1,msgerr .ifdf $longer .asciz "b" .iff .asciz "a" .endc .even .endm .macro errdef fovrfl=0 fundfl=2 fzdiv=4 ngsqrt=6 badlog=10 intov=12 .endm errdef f0=%0 f1=%1 f2=%2 f3=%3 f4=%4 .mcall $sig .hiseg al languages .title sin and cos .globl sin,cos .ifndf fpu .globl $adr,$mlr,$sbr,$dvr,$intr .endc ; sin cos the real sin and cosine functions ; calling sequence: ; fortran standard (1 arg) ; returns sin or cos of arg in r0 and r1 finit .ifndf fpu cos: mov 2(r5),r4 ;get argument address clr -(sp) ;make room for quadrant flag mov 2(r4),-(sp) ;push argument mov @r4,-(sp) mov #007733,-(sp) ;push pi/2 mov #040311,-(sp) mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ .word $adr,sincos ;cos(x)=sin(x+pi/2) sin: mov 2(r5),r4 ;get argument address clr -(sp) ;make room for quadrant flag mov 2(r4),-(sp) mov @r4,-(sp) ;push argument sincos: asl @sp ;remove and save sign ror 4(sp) ;in quadrant flag ror @sp mov #007733,-(sp) ;push 2*pi mov #040711,-(sp) mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ .word $dvr ;x/2pi .word dup ;2 copies .word $intr ;int(x/2pi) .word $sbr ;fract(x/2pi) .word x4 ;4*fract(x/2pi) .word dup ;2 copies .word $intr ;int(4*fract(x/2pi)) .word quad ;save int(......) .word $sbr ;y=fract(4*fract(x/2pi)) .word qset ;reduce y to (-1,1) qsetre: .word dup ;2 copies .word dup ;3 copies .word $mlr ;y*y .word poly ;push coefficients .word $mlr ;a4*y**2 .word $adr ;a4*y**2+a3 .word $mlr .word $adr .word $mlr .word $adr .word $mlr .word $adr .word $mlr ;((((a4*z+a3)*z+a3)*z+a2)*z ;+a1)*z+a0)*z z=y*y .word rtn rtn: mov (sp)+,r0 ;pop high order result mov (sp)+,r1 tst (sp)+ ;pop quadrant flag bge rtn1 ;jump if argument was + add #100000,r0 ;sin(-x)=-sin(x) rtn1: rts pc ;back to caller dup: mov 2(sp),-(sp) ;duplicate stack item mov 2(sp),-(sp) jmp @(r4)+ x4: tst @sp ;check for 0 fraction beq rtn ;quit now incb 1(sp) ;quadruple stack item jmp @(r4)+ quad: bis @sp,8.(sp) ;save quadrant number jmp @(r4)+ qset: tstb 4(sp) ;test quadrant beq q13 ;jump if first or third quad add #100000,@sp ;negate stack item clr -(sp) ;push a floating 1. mov #40200,-(sp) mov (sp)+,r4 ;enter threaded mode jsr r4,@(pc)+ .word $adr,qsetr ;x=1.-x qsetr: mov #qsetre,r4 ;point back into list q13: asrb 5(sp) ;test quadrant bcc qout ;jump if first or second add #100000,@sp ;negate stack item qout: jmp @(r4)+ poly: mov (sp)+,r0 ;save y*y mov (sp)+,r1 mov #consts+4,r2 ;point to list of coefficients mov #5,r3 br poly1 poly2: mov r1,-(sp) ;push y*y mov r0,-(sp) poly1: mov -(r2),-(sp) mov -(r2),-(sp) dec r3 ;count coefficients bgt poly2 jmp @(r4)+ .endc .ifdf fpu f0=%0 f1=%1 f2=%2 f3=%3 cos: setd ;double precision fp ldcfd @2(r5),f0 ;get argument addd piov2,f0 ;cos(x)= sin(x+pi/2) br sincos sin: setd ;double precison fp ldcfd @2(r5),f0 ;get argument sincos: seti ;short integers mov #fconst,r0 ;pointer to constants clr r4 ;sign flag: + arg cfcc ;get sign of argument bge pos inc r4 ;sign flag: - arg absd f0 ;remove argument sign pos: divd (r0)+,f0 ;x/(pi/2) modd #^f0.25,f0 ;f0=fract(x/2pi) setf ;single precision fp ldcdf f0,f0 ;convert argument cfcc beq rtn ;check for 0 fraction modf #^f4.0,f0 ;f0=fract(4*fract(x/2pi)) stcfi f1,r1 ;quad=int(4*fract(x/2pi)) ror r1 bcc q13 ;jump if first or third quad negf f0 addf #^f1.0,f0 ;y=1.0-x q13: ror r1 bcc q12 ;jump if first or second quad negf f0 ;y= -y q12: ldf f0,f2 mulf f2,f2 ;z=y**2 mov #4,r1 ;count of constants for poly ldf (r0)+,f1 ;initialize accumulator xpand: mulf f2,f1 dec r1 ;coun addf (r0)+,f1 ;f1:= z*f1 + c(i) bgt xpand ;loop mulf f1,f0 ;f0:= y*f1 tst r4 ;test sign flag beq rtn negf f0 ;sin(-x) = -sin(x) rtn: stf f0,-(sp) ;move result to stack mov (sp)+,r0 ;and thence to r0,r1 mov (sp)+,r1 rts pc ;exit fconst: piov2: .word 040311,007732 ;pi/2 (double precision) .word 121041,064302 ; order-dependent constants .endc .word 035036,153672 ;.00015148419 .word 136231,023143 ;-.00467376557 .word 037243,032130 ;.0796896793 .word 140045,056741 ;-.645963711 consts: .word 040311,007733 ;1.570796318 .end nd ;loop mulf f1,f0 ;f0:= y*f1 tst r4 ;test sign flag beq rtn negf f0 ;sin(-x) = -sin(x) rtn: stf f0,-(sp) .title sqrt square-root errdef .globl sqrt .ifdf fis .globl $adr,$dvr .endc ; sqrt the real square root function ; calling sequence: ; fortran standard (1 arg) ; returns the square root in r0 and r1. .ifdf fpu!fis .ifdf fpu f0=%0 f1=%1 f2=%2 sqrt: mov @2(r5),r1 ;get high order argument .endc .ifndf fpu sqrt: mov r5,-(sp) mov 2(r5),r5 ;get argument address mov @r5,r1 ;get high order argument .endc bgt 1$ ;positive, take sqrt beq zero ;fast exit if zero error ngsqrt ;sqrt of negative number mov @r5,r1 ;let take sqrt of absolute value bic #100000,r1 ;makes it positive 1$: .ifndf fpu mov #3,-(sp) ;push iteration count .endc asr r1 ;form initial estimate add #20100,r1 clr -(sp) ;use only high order parts first mov r1,-(sp) ;'cause add and divide are .ifndf fpu clr -(sp) ;faster that way mov @r5,-(sp) clr -(sp) mov r1,-(sp) loop: mov (sp)+,r4 ;get into polish m@de jsr r4,@(pc)+ .word $dvr,$adr,unpol ;(x/e+e) unpol: sub #200,@sp ;(x/e+e)/2 dec 4(sp) ;count loop beq out mov 2(r5),-(sp) ;use low order parts mov @r5,-(sp) ;too from now on mov 6(sp),-(sp) mov 6(sp),-(sp) br loop ;go for another iteration out: mov (sp)+,r0 ;get result into r0,r1 mov (sp)+,r1 tst (sp)+ ;pop iteration counter rtn: mov (sp)+,r5 rts pc ;return to caller zero: clr r0 clr r1 br rtn .endc .ifdf fpu mov #3,r0 ;iteration count ldf (sp)+,f0 ;get initial estimate ldf @2(r5),f2 ;get x loop: ldf f0,f1 ;e=e' ldf f2,f0 ;x divf f1,f0 ;x/e addf f1,f0 ;x/e+e dec r0 ;count divf #^f2.0,f0 ;e'=(x/e+e)/2 bgt loop stf f0,-(sp) ;result to stack mov (sp)+,r0 ;and thence to r0,r1 mov (sp)+,r1 rtn: rts pc ;return to caller zero: clr r0 clr r1 br rtn .endc .endc .ifndf fis&fpu ;jwr sqrt: mov r5,-(sp) mov 2(r5),r5 mov (r5)+,r0 ;get high part of arg bgt okroot ;was it positive? beq zroot ;special case check for zero root error ngsqrt zroot: clr r0 ;return zero as special case clr r1 ;necessary because of implied norm bit br sqout okroot: asl r0 ;adjust exponent and fraction clr r2 ;get the fraction bisb r0,r2 sec ;setup the implied normalize bit rorb r2 mov @r5,r3 ;now get the low part clc ror r0 ;halve exponent tstb r0 ;was it odd? bmi 2$ ;yes, our assumed radix pt is ok asl r3 ;no, make like it was even rol r2 2$: add #40200,r0 ;fix exponent now mov r0,-(sp) ;push for later ; r0,r1 = new root (radicator) ; r2,r3 = agrument fraction (radicand) ; r4,r5 = epsilon bit shift register mov #200,r4 ;init epsilon bit clr r5 clr r0 ;clear radicator clr r1 sqloop: add r5,r1 ;tentatively add epsilon bit in add r4,r0 ;to whichever half it's in cmp r0,r2 ;see if radicator goes into radinand bne 1$ cmp r1,r3 1$: bhi 2$ ;it didn't sub r1,r3 ;it did, actually subtract it now sbc r2 sub r0,r2 add r5,r1 ;double the epsilon bit adc r0 ;this can cause a carry add r4,r0 br 3$ ;go do the shifts 2$: sub r5,r1 ;it didn't go, take out that bit sub r4,r0 3$: asl r3 ;first shift the radicand up rol r2 asr r4 ;now shift the epsilon bit ror r5 bcc sqloop ;did it go out the end? ;yes, prepare to round sqdone: cmp r0,r2 bne 1$ cmp r1,r3 1$: adc r1 ;set c bit to low bit now ;this step clears the carry movb r0,@sp ;store the fraction with the exponent mov (sp)+,r0 ;pop it right back ror r0 ;put into actual floating format ror r1 ;former c bit to c bit adc r1 ;now do the round (not the square) adc r0 sqout: mov (sp)+,r5 ;pop the pointer rts pc ;finally return .endc .end rol r2 asr r4 ;now shift the epsilon bi .title ux.sml ;*************************** .macro $param r0=%0 r1=%1 r2=%2 r3=%3 r4=%4 r5=%5 sp=%6 pc=%7 .endm $param ;*************************** .macro $indir 104400 + 0 .endm $indir ;*************************** .macro $exit 104400 + 1 .endm $exit ;*************************** .macro $fork 104400 + 2 .endm $fork ;*************************** .macro $read 104400 + 3 .endm $read ;*************************** .macro $write 104400 + 4 .endm $write ;*************************** .macro $open 104400 + 5 .endm $open ;*************************** .macro $close 104400 + 6 .endm $close ;*************************** .macro $wait 104400 + 7 .endm #wait ;*************************** .macro $creat 104400 + 8. .endm $creat ;*************************** .macro $link 104400 + 9. .endm $link ;*************************** .macro $unlink 104400 + 10. .endm $unlink ;****************************** .macro $exec 104400 + 11. .endm $exec ;*************************** .macro $chdir 104400 + 12. .endm $chdir ;**************************** .macro $time 104400 + 13. .endm $time ;**************************** .macro $mknod 104400 + 14. .endm $mknod ;**************************** .macro $chmod 104400 + 15. .endm $chmod ;*************************** .macro $chown 104400 + 16. .endm $chown ;*************************** .macro $break 104400 + 17. .endm $break ;*************************** .macro $stat 104400 + 18. .endm $stat ;*************************** .macro $seek 104400 + 19. .endm $seek ;************************* .macro $getpid 104400 + 20. .endm ;****************************** .macro $mount 104400 + 21. .endm $mount ;***************************** .macro $umount 104400 + 22. .endm $umount ;**************************** .macro $setuid 104400 + 23. .endm $setuid .macro $setruid 104400 + 23. .endm $setruid ;**************************** .macro $getruid 104400 + 24. .endm .macro $getuid 104400 + 24. .endm ;*************************** .macro $stime 104400 + 25. .endm $stime ;******************************* .macro $ptrace 104400 + 26. .endm ;****************************** .macro $fstat 104400 + 28. .endm $fstat ;***************************** .macro $smdate 104400 + 30. .endm $smdate ;***************************** .macro $stty 104400 + 31. .endm $stty ;**************************** .macro $gtty 104400 + 32. .endm $gtty ;**************************** .macro $nice 104400 + 34. .endm $nice ;**************************** .macro $sleep 104400 + 35. .endm $sleep ;***************************** .macro $sync 104400 + 36. .endm $sync ;***************************** .macro $kill 104400 + 37. .endm $kill ;***************************** .macro $switch 104400 + 38. .endm $switch ;**************************** .macro $dup 104400 + 41. .endm $dup ;***************************** .macro $pipe 104400 + 42. .endm $pipe ;***************************** .macro $times 104400 + 43. .endm $times ;**************************** .macro $prof 104400 + 44. .endm $prof .macro $profile 104400 + 44. .endm ;***************************** .macro $seteuid ;.macro $setgid 104400 + 46. .endm ;**************************** .macro $geteuid ;.macro $getgid 104400 + 47. .endm ;**************************** .macro $sig 104400 + 48. .endm $sig ;****************************** .end 2. .endm $pipe ;***************************** .macro $times 104400 + 43. .endm $times ;**************************** .macro $prof 104400 + 44. .endm $prof .macro $profile 104400 + 44. .endm ;***************************** .macro $seteuid ;.macro $setgid 104400 + 46. .endm ;**************************** .macro $geteuid ;.macro $getgid 104400 + 47. .endm ;**************************** .macro $sig 1 report on basic version 4-a the new basic system adds matrix commands and a new parser and unparser to make using the old "extend" commands easier. assembling and linking the system is done as usual with the supplied command files. the attatched document "basmat" describes the implementation of the matrix commands. changes include: 1). "sys" is now the command to exit, rather than "bye". "bye" will do a logout at some future date. 2). "protocol" and "unprotocol" have replaced the formerly arcane "extend(1)" and "extend(1)" commands. 3). 'unlink "file"' has replaced "extend(2)". 4). "ddt" has replaced "sys(1)". 5). "info" types the file /lib/basic/news. remaining bugs are: 1). 'line# sys' causes a core dump. apparently a bug in the parser. please report bugs, deficiencies, and suggestions to john burruss (main system) or jeffery herrmann (matrix package and new parser) c/o director's office undergraduate science center, harvard university 1 oxford street cambridge, mass. 02138 nd "extend(1)" commands. 3). 'unlink "file"' has replaced "extend(2)". 4). "ddt" has replaced "sys(1)". 5). "info" types the file /lib/basic/news. remaining bugs are: 1). 'line# sys' causes a core dump. apparently a bug in the parser. please report bugs, deficiencies, and suggestions to john burruss (main system) or jeffery herrmann (matrix package and new parser) c/o director's office undergraduate science center, harvard university 1 oxford street camb