perm filename CC.MAC[LSP,BGB] blob
sn#001396 filedate 1972-11-05 generic text, type T, neo UTF8
00100 SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
00200
00300 CADDDR: SKIPA A,(A)
00400 CADDAR: LIPZ A,(A)
00500 CADDR: SKIPA A,(A)
00600 CADAR: LIPZ A,(A)
00700 CADR: SKIPA A,(A)
00800 CAAR: LIPZ A,(A)
00900 CAR: LIPZ A,(A)
01000 POPJ P,
01100
01200 CDDDDR: SKIPA A,(A)
01300 CDDDAR: LIPZ A,(A)
01400 CDDDR: SKIPA A,(A)
01500 CDDAR: LIPZ A,(A)
01600 CDDR: SKIPA A,(A)
01700 CDAR: LIPZ A,(A)
01800 CDR: LAPZ A,(A)
01900 POPJ P,
02000
02100 CAADDR: SKIPA A,(A)
02200 CAADAR: LIPZ A,(A)
02300 CAADR: SKIPA A,(A)
02400 CAAAR: LIPZ A,(A)
02500 JRST CAAR
02600
02700 CDADDR: SKIPA A,(A)
02800 CDADAR: LIPZ A,(A)
02900 CDADR: SKIPA A,(A)
03000 CDAAR: LIPZ A,(A)
03100 JRST CDAR
03200
03300 CAAADR: SKIPA A,(A)
03400 CAAAAR: LIPZ A,(A)
03500 JRST CAAAR
03600
03700 CDDADR: SKIPA A,(A)
03800 CDDAAR: LIPZ A,(A)
03900 JRST CDDAR
04000
04100 CDAADR: SKIPA A,(A)
04200 CDAAAR: LIPZ A,(A)
04300 JRST CDAAR
04400
04500 CADADR: SKIPA A,(A)
04600 CADAAR: LIPZ A,(A)
04700 JRST CADAR
00100
00200 QUOTE: LIPZ A,(A) ;car and quote duplicated for backtrace
00300 POPJ P,
00400
00500 AASCII: PUSHJ P,NUMVAL
00600 LSH A,↑D29
00700 PUSHJ P,FWCONS
00800 PUSHJ P,NCONS
00900 PNGNK1: PUSHJ P,NCONS
01000 FOO MOVEI B,PNAME
01100 PUSHJ P,XCONS
01200 ACONS: TROA B,-1
01300 NCONS: TRZA B,-1
01400 XCONS: EXCH B,A
01500 CONS: AOS CONSVAL
01600 HRL B,A
01700 SKIPN A,F
01800 JRST [ HLR A,B
01900 PUSHJ P,AGC
02000 JRST .-1]
02100 LAC F,(F)
02200 DAC B,(A)
02300 POPJ P,
02400
02500 ;new consing routines-not finished yet
02600 ;acons: troa b,-1
02700 ;ncons: trz b,-1
02800 ;cons: exch b,a
02900 ;xcons: hrl a,b
03000 ; exch a,(f)
03100 ; exch a,f
03200 ; popj p,
03300
03400 PATOM: CAML A,orgFWS
03500 JRST TRUE
03600 CAML A,orgHWS
03700 ATOM: CAILE A,INUMIN
03800 JRST TRUE
03900 HLLE A,(A)
04000 AOJE A,TRUE
04100 JRST FALSE
00100 EQ: CAMN A,B
00200 JRST TRUE
00300 JRST FALSE
00400
00500 LENGTH: MOVEI B,0
00600 LNGTH1: CAILE A,INUMIN
00700 JRST FIX1
00800 HLLE C,(A)
00900 AOJE C,FIX1
01000 LAPZ A,(A)
01100 AOJA B,LNGTH1
01200
01300 LAST: LAPZ B,(A)
01400 CAILE B,INUMIN
01500 POPJ P,
01600 HLLE B,(B)
01700 AOJE B,CPOPJ
01800 LAPZ A,(A)
01900 JRST LAST
02000
02100 RPLACA: DIP B,(A)
02200 POPJ P,
02300
02400 RPLACD: DAP B,(A)
02500 POPJ P,
02600
02700 ZEROP: PUSHJ P,NUMVAL
02800 NOT:
02900 NULL: JUMPN A,FALSE
03000 TRUE:
03100 FOO MOVEI A,TRUTH
03200 POPJ P,
03300
03400 FW0CNS: MOVEI A,0
03500 FWCONS: JUMPN FF,FWC1
03600 EXCH A,FWC0#
03700 PUSHJ P,AGC
03800 EXCH A,FWC0
03900 FWC1: EXCH A,(FF)
04000 EXCH A,FF
04100 POPJ P,
04200
00100 SASSOC: PUSHJ P,SAS1
00200 JCALLF 0,(C)
00300 POPJ P,
00400
00500 SAS0: LIPZ B,T
00600 SAS1: JUMPE B,CPOPJ
00700 MOVS T,(B)
00800 MOVS TT,(T)
00900 CAIE A,(TT)
01000 JRST SAS0
01100 LAPZ A,T
01200 CPOPJ1: AOS (P)
01300 POPJ P,
01400
01500 ASSOC: PUSHJ P,SAS1
01600 FALSE: MOVEI A,NIL
01700 CPOPJ: POPJ P,
01800
01900 REVERSE: LAC T,A
02000 MOVEI A,0
02100 JUMPE T,CPOPJ
02200 LIPZ B,(T)
02300 LAPZ T,(T)
02400 PUSHJ P,XCONS
02500 JUMPN T,.-3
02600 POPJ P,
02700
02800
02900 REMPROP: LAPZ T,(A)
03000 MOVS TT,(T)
03100 CAIN B,(TT)
03200 JRA TT,REMP1
03300 LIPZ A,TT
03400 LAPZ T,(A)
03500 JUMPN T,REMPROP+1
03600 JRST FALSE
03700
03800 REMP1: DAP TT,(A)
03900 JRST TRUE
00100 GET: LAPZ A,(A)
00200 MOVS D,(A)
00300 CAIN B,(D)
00400 JRST CADR
00500 LIPZ A,D
00600 LAPZ A,(A)
00700 JUMPN A,GET+1
00800 POPJ P,
00900
01000 GETL: LAPZ A,(A)
01100 GETL0: LIPZ T,(A)
01200 LAC C,B
01300 GETL1: MOVS TT,(C)
01400 CAIN T,(TT)
01500 POPJ P,
01600 LIPZ C,TT
01700 JUMPN C,GETL1
01800 LAPZ A,(A)
01900 LAPZ A,(A)
02000 JUMPN A,GETL0
02100 POPJ P,
02200
02300 NUMBERP: CAILE A,INUMIN
02400 JRST TRUE
02500 HLLE T,(A)
02600 AOJN T,FALSE
02700 LAPZ A,(A)
02800 LIPZ A,(A)
02900 FOO CAIE A,FIXNUM
03000 FOO CAIN A,FLONUM
03100 JRST TRUE
03200 NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
00100 PUTPROP: LAC T,A
00200 LAPZ A,(A)
00300 CSET3: MOVS TT,(A)
00400 LIPZ A,TT
00500 CAIN C,(TT)
00600 JRST CSET2
00700 LAPZ A,(A)
00800 JUMPN A,CSET3
00900 LAPZ A,(T)
01000 PUSHJ P,XCONS
01100 LAPZ B,C
01200 PUSHJ P,XCONS
01300 DAP A,(T)
01400 JRST CADR
01500
01600 CSET2:
01700 FOO CAIE C,VALUE
01800 JRST CSET1
01900 LAPZ T,(B)
02000 LIPZ A,(A)
02100 DAP T,(A)
02200 JRST PROG2
02300
02400 CSET1: DIP B,(A)
02500 PROG2: LAC A,B
02600 POPJ P,
02700
02800 DEFPROP:
02900 LAPZ B,(A)
03000 LAPZ C,(B)
03100 LIPZ A,(A)
03200 LIPZ B,(B)
03300 LIPZ C,(C)
03400 PUSH P,A
03500 PUSHJ P,PUTPROP
03600 JRST POPAJ
00100 EQUAL: LAC C,P
00200 EQUAL1: CAMN A,B
00300 JRST TRUE
00400 LAC T,A
00500 LAC TT,B
00600 PUSHJ P,ATOM
00700 EXCH A,B
00800 PUSHJ P,ATOM
00900 CAMN A,B
01000 JRST EQUAL3
01100 EQUAL4: LAC P,C
01200 JRST FALSE
01300
01400 EQUAL3: JUMPN A,EQ2
01500 PUSH P,T
01600 PUSH P,TT
01700 LIPZ A,(T)
01800 LIPZ B,(TT)
01900 PUSHJ P,EQUAL1
02000 JUMPE A,EQUAL4
02100 POP P,B
02200 POP P,A
02300 LAPZ A,(A)
02400 LAPZ B,(B)
02500 JRST EQUAL1
02600
02700 EQ2: PUSH P,T
02800 LAC A,T
02900 PUSHJ P,NUMBERP
03000 JUMPE A,EQUAL4
03100 LAC A,TT
03200 PUSHJ P,NUMBERP
03300 JUMPE A,EQUAL4
03400 LAC A,(P)
03500 DAC C,(P)
03600 LAC B,TT
03700 JSP C,OP
03800 JUMPL COMP3
03900 JUMPL COMP3
04000
04100 COMP3: POP P,C
04200 CAME A,TT
04300 JRST EQUAL4
04400 JRST TRUE
00100 SUBS5: LAPZ A,SUBAS
00200 POPJ P,
00300
00400 SOBST: DAC A,SUBAS#
00500 DAC B,SUBBS#
00600 SUBS0A: LAC A,SUBAS
00700 LAC B,SUBBS
00800 PUSH P,C
00900 LAC A,C
01000 PUSHJ P,EQUAL
01100 POP P,C
01200 JUMPN A,SUBS5
01300 CAILE C,INUMIN
01400 JRST EV6A
01500 HLLE T,(C)
01600 AOJN T,SUBS2
01700 EV6A: LAC A,C
01800 POPJ P,
01900
02000 SUBS2: PUSH P,C
02100 LIPZ C,(C)
02200 PUSHJ P,SUBS0A
02300 EXCH A,(P)
02400 LAPZ C,(A)
02500 PUSHJ P,SUBS0A
02600 POP P,B
02700 JRST XCONS
00100 NCONC: TDZA R,R
00200 APPEND: MOVEI R,.APPEND-.NCONC
00300 JUMPE T,FALSE
00400 POP P,B
00500 APP2: AOJE T,PROG2
00600 POP P,A
00700 PUSHJ P,.NCONC(R)
00800 LAC B,A
00900 JRST APP2
01000
01100 .NCONC: JUMPE A,PROG2
01200 LAC TT,A
01300 LAC C,TT
01400 LAPZ TT,(C)
01500 JUMPN TT,.-2
01600 DAP B,(C)
01700 POPJ P,
01800
01900 .APPEND: JUMPE A,PROG2
02000 MOVEI C,AR1
02100 LAC TT,A
02200 APP1: LIPZ A,(TT)
02300 PUSH P,B
02400 PUSHJ P,CONS ;saves b
02500 POP P,B
02600 DAP A,(C)
02700 LAC C,A
02800 LAPZ TT,(TT)
02900 JUMPN TT,APP1
03000 JRST SUBS4
00100 MEMBER: DAC A,SUBAS
00200 MEMB1: JUMPE B,FALSE
00300 DAC B,SUBBS
00400 LAC A,SUBAS
00500 LIPZ B,(B)
00600 PUSHJ P,EQUAL
00700 JUMPN A,CPOPJ
00800 LAC B,SUBBS
00900 LAPZ B,(B)
01000 JRST MEMB1
01100
01200 MEMQ: JUMPE B,FALSE
01300 MOVS C,(B)
01400 CAIN A,(C)
01500 JRST TRUE
01600 LIPZ B,C
01700 JUMPN B,MEMQ+1
01800 JRST FALSE
01900
02000 AND:
02100 FOO HRLI A,TRUTH
02200 OR: LIPZ C,A
02300 PUSH P,C
02400 ANDOR: LAPZ C,A
02500 JUMPE C,AOEND
02600 MOVSI C,(SKIPE (P))
02700 TLNE A,-1
02800 MOVSI C,(SKIPN (P))
02900 XCT C
03000 JRST AOEND
03100 DAC A,(P)
03200 LIPZ A,(A)
03300 PUSHJ P,EVAL
03400 EXCH A,(P)
03500 HRR A,(A)
03600 JRST ANDOR
03700
03800 AOEND: POP P,A
03900 SKIPE A
04000 FOO MOVEI A,TRUTH
04100 POPJ P,
00100 GENSYM: LAC B,[POINT 7,GNUM,34]
00200 MOVNI C,4
00300 MOVEI TT,"0"
00400
00500 GENSY2: LDB T,B
00600 AOS T
00700 DPB T,B
00800 CAIG T,"9"
00900 JRST GENSY1
01000 DPB TT,B
01100 ADD B,[XWD 70000,0]
01200 AOJN C,GENSY2
01300
01400 GENSY1: LAC A,GNUM
01500 PUSHJ P,FWCONS
01600 PUSHJ P,NCONS
01700 JRST PNGNK1
01800
01900 GNUM: ASCII /G0000/ ;*
02000
02100 CSYM: LIPZ A,(A)
02200 PUSH P,A
02300 FOO MOVEI B,PNAME
02400 PUSHJ P,GET
02500 JUMPE A,NOPNAM
02600 LIPZ A,(A)
02700 LAC A,(A)
02800 DAC A,GNUM
02900 JRST POPAJ
00100 LIST: LAC B,A
00200 FOO MOVEI A,CEVAL
00300 JRST MAPCAR
00400
00500 EELS: LIPZ TT,(T) ;interpret lsubr call
00600 LAPZ A,(AR1)
00700 ILIST: MOVEI T,0
00800 JUMPE A,ILIST2
00900 ILIST1: PUSH P,A
01000 LIPZ A,(A)
01100 PUSH P,TT
01200 DIP T,(P)
01300 PUSHJ P,EVAL
01400 ILIST3: POP P,TT
01500 HLRE T,TT
01600 EXCH A,(P)
01700 LAPZ A,(A)
01800 SOS T
01900 JUMPN A,ILIST1
02000 ILIST2: JRST (TT)
02100
02200 MAPC: TLO A,400000
02300 MAP: TLOA A,200000
02400 MAPCAR: TLO A,400000
02500 MAPLIST: JUMPE B,FALSE
02600 PUSH P,A
02700 PUSH P,B
02800 PUSH P,B
02900 DIPZ P,(P)
03000 MAPL2: LAC A,-1(P)
03100 SKIPGE -2(P)
03200 LIPZ A,(A)
03300 CALLF 1,@-2(P)
03400 LDB C,[POINT 1,-2(P),1]
03500 JUMPN C,MAP1
03600 PUSHJ P,NCONS
03700 HLR B,(P)
03800 DAP A,(B)
03900 DIP A,(P)
04000 MAP1: LAPZ B,@-1(P)
04100 DAC B,-1(P)
04200 JUMPN B,MAPL2
04300 POP P,AR1
04400 SUB P,[XWD 2,2]
04500 SUBS4: LAPZ A,AR1
04600 POPJ P,0
00100 PA3: 0 ;lh=0=>rh =next prog statement *
00200 ;lh - =>rh = tag to go to
00300 PA4: 0 ;lh=-1,rh=pntr to prog less bound var list *
00400 ;lh=+,rh return value
00500 ;2.1=>dont do unbnd
00600
00700 PROG: PUSH P,PA3
00800 PUSH P,PA4
00900 LIPZ TT,(A)
01000 LAPZ A,(A)
01100 HRROM A,PA4
01200 DAC A,PA3
01300 JUMPE TT,PG0
01400 MOVSI C,1
01500 FOO MOVEI B,VALUE
01600 DAC SP,SPSV#
01700 ANDCAM C,PA4
01800
01900 PG7A: LIPZ A,(TT)
02000 MOVEI AR1,0
02100 PUSHJ P,BIND
02200 LAPZ TT,(TT)
02300 JUMPN TT,PG7A
02400 PUSH SP,SPSV
02500
02600 PG0: SKIPA T,PA3
02700 PG5A: LAC T,A
02800 PG1: JUMPE T,PG2
02900 LIPZ A,(T)
03000 LAPZ T,(T)
03100 HLLE B,(A)
03200 AOJE B,PG1
03300 DAC T,PA3
03400 PUSHJ P,EVAL
03500 SKIPL A,PA4
03600 JRST PG4 ;return
03700 SKIPL T,PA3
03800 JRST PG1
03900 PG5: JUMPE A,EG1
04000 LIPZ TT,(A)
04100 LAPZ A,(A)
04200 CAIN TT,(T)
04300 JRST PG5A ;found tag
04400 JRST PG5
04500
04600 PG2: TDZA A,A
04700 PG4: HRRZS A
04800 MOVSI B,1
04900 TDNN B,PA4
05000 PUSHJ P,UNBIND
05100 ERRP4: POP P,PA4
05200 POP P,PA3
05300 POPJ P,
05400
05500
05600 GO: LIPZ A,(A)
05700 HRROM A,PA3
05800 HLLE B,(A)
05900 AOJE B,FALSE
06000 PUSHJ P,EVAL
06100 JRST GO+1
06200
06300
06400 RETURN: HLL A,PA4
06500 TLZ A,-2
06600 DAC A,PA4
06700 POPJ P,
06800
06900 SETQ: LIPZ B,(A)
07000 PUSH P,B
07100 PUSHJ P,CADR
07200 PUSHJ P,EVAL
07300 LAC B,A
07400 POP P,A
07500 SET: LAC AR1,B
07600 PUSHJ P,BIND
07700 SUB SP,[XWD 1,1]
07800 LAC A,AR1
07900 POPJ P,
08000
08100 CON2: LAPZ A,(T)
08200 COND: JUMPE A,CPOPJ ;entry
08300 PUSH P,A
08400 LIPZ A,(A)
08500 LIPZ A,(A)
08600 PUSHJ P,EVAL
08700 POP P,T
08800 JUMPE A,CON2
08900 LIPZ T,(T)
09000 COND2: LAPZ T,(T)
09100 JUMPE T,CPOPJ
09200 PUSH P,T
09300 LIPZ A,(T)
09400 PUSHJ P,EVAL
09500 POP P,T
09600 JRST COND2
00100 SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
00200
00300 ;macro expander -- (foo a b c) => (*foo (*foo a b) c)
00400 EXPAND: LAC C,B
00500 LAPZ A,(A)
00600 PUSHJ P,REVERSE
00700 JRST EXPA1
00800
00900 EXPN1: LAC C,B
01000 EXPA1: LAPZ T,(A)
01100 LIPZ A,(A)
01200 JUMPE T,CPOPJ
01300 PUSH P,A
01400 LAC A,T
01500 PUSHJ P,EXPA1
01600 EXCH A,(P)
01700 PUSHJ P,NCONS
01800 POP P,B
01900 PUSHJ P,XCONS
02000 LAC B,C
02100 JRST XCONS
02200
00100
00200 ADD1: CAILE A,INUMIN
00300 CAIL A,-2
00400 SKIPA B,[INUM0+1]
00500 AOJA A,CPOPJ
00600 .PLUS: JSP C,OP
00700 ADD A,TT
00800 FADR A,TT
00900
01000 SUB1: CAILE A,INUMIN+1
01100 SOJA A,CPOPJ
01200 MOVEI B,INUM0+1
01300 .DIF: JSP C,OP
01400 SUB A,TT
01500 FSBR A,TT
01600
01700 .TIMES: JSP C,OP
01800 IMUL A,TT
01900 FMPR A,TT
02000
02100 .QUO: CAIN B,INUM0
02200 JRST ZERODIV
02300 JSP C,OP
02400 IDIV A,TT
02500 FDVR A,TT
02600
02700 .GREAT: EXCH A,B
02800 JUMPE B,FALSE
02900 .LESS: JUMPE A,CPOPJ
03000 JSP C,OP
03100 JRST COMP2 ;bignums know about me
03200 JRST COMP2
03300
03400 COMP2: CAML A,TT
03500 JRST FALSE
03600 JRST TRUE
00100 MAKNUM:
00200 FOO CAIN B,FIXNUM
00300 JRST FIX1A
00400 FLO1A:
00500 FOO MOVEI B,FLONUM
00600 PUSHJ P,FWCONS
00700 JRST ACONS-1
00800
00900 FIX1B: SUBI A,INUM0
01000 FOO MOVEI B,FIXNUM
01100 PUSHJ P,FWCONS
01200 JRST ACONS-1
01300
01400 NUMVLX: JFCL 17,.+1
01500 NUMVAL: CAIG A,INUMIN
01600 JRST NUMAG1
01700 SUBI A,INUM0
01800 FOO MOVEI B,FIXNUM
01900 POPJ P,
02000
02100 NUMAG1: DAC A,AR1
02200 LAPZ A,(A)
02300 LIPZ B,(A)
02400 LAPZ A,(A)
02500 FOO CAIE B,FIXNUM
02600 FOO CAIN B,FLONUM
02700 SKIPA A,(A)
02800 NUMV4: SKIPA A,AR1
02900 POPJ P,
03000 NUMV2: PUSHJ P,EPRINT ;bignums know about me
03100 JRST NONNUM
03200
03300 NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
00100 FLOAT: IDIVI A,400000
00200 SKIPE A
00300 TLC A,254000
00400 TLC B,233000
00500 FADR A,B
00600 POPJ P,
00700
00800 FIX: PUSH P,A
00900 PUSHJ P,NUMVAL
01000 FOO CAIE B,FLONUM
01100 JRST POPAJ
01200 MULI A,400
01300 TSC A,A
01400 JFCL 17,.+1
01500 ASH B,-243(A)
01600 FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
01700 POP P,A
01800 FIX1: LAC A,B
01900 JRST FIX1A
02000
02100 MINUSP: PUSHJ P,NUMVAL
02200 JUMPGE A,FALSE
02300 JRST TRUE
02400
02500 MINUS: PUSHJ P,NUMVLX
02600 MOVNS A
02700 JFCL 10,@OPOV
02800 JRST MAKNUM
02900
03000 ABS: PUSHJ P,NUMVLX
03100 MOVMS A
03200 JRST MINUS+2
00100 DIVIDE: CAIN B,INUM0
00200 JRST ZERODIV
00300 JSP C,OP
00400 JUMPN RDIV ;bignums know about me
00500 JRST ILLNUM
00600 RDIV: IDIV A,TT
00700 PUSH P,B
00800 PUSHJ P,FIX1A
00900 EXCH A,(P)
01000 PUSHJ P,FIX1A
01100 POP P,B
01200 JRST XCONS
01300
01400 REMAINDER:
01500 PUSHJ P,DIVIDE
01600 JRST CDR
01700
01800 FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
01900 ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
02000 FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
02100 ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
02200
02300 GCD: JSP C,OP
02400 JUMPA GCD2 ;bignums know about me
02500 JRST ILLNUM
02600 GCD2: MOVMS A
02700 MOVMS TT
02800 ;euclid's algorithm
02900 GCD3: CAMG A,TT
03000 EXCH A,TT
03100 JUMPE TT,FIX1A
03200 IDIV A,TT
03300 LAC A,B
03400 JRST GCD3
00100 ;general arithmetic op code routine for mixed types
00200
00300 OP: CAIG A,INUMIN
00400 JRST OPA1
00500 SUBI A,INUM0
00600 CAIG B,INUMIN
00700 JRST OPA2
00800 HRREI TT,-INUM0(B)
00900 XCT (C) ;inum op (cannot cause overflow)
01000 FIX1A: ADDI A,INUM0
01100 CAILE A,INUMIN
01200 CAIL A,-1
01300 JRST FIX1B
01400 POPJ P,
01500
01600 OPA1: LAPZ A,(A)
01700 LIPZ T,(A)
01800 LAPZ A,(A)
01900 FOO CAIE T,FIXNUM
02000 JRST OPA6
02100 SKIPA A,(A)
02200 OPA2:
02300 FOO MOVEI T,FIXNUM
02400 CAILE B,INUMIN
02500 JRST OPB2
02600 LAPZ B,(B)
02700 LAPZ TT,(B)
02800 LIPZ B,(B)
02900 FOO CAIE B,FIXNUM
03000 JRST OPA5
03100 SKIPA TT,(TT)
03200 OPB2: HRREI TT,-INUM0(B)
03300 LAC AR1,A
03400 JFCL 17,.+1
03500 XCT (C) ;fixed pt op
03600 OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
03700 JRST FIX1A
03800
03900 OPA6: CAILE B,INUMIN
04000 JRST OPB7
04100 LAPZ B,(B)
04200 LAPZ TT,(B)
04300 LIPZ B,(B)
04400 FOO CAIE B,FLONUM
04500 JRST OPB3
04600 FOO CAIE T,FLONUM
04700 JRST NUMV3
04800 LAC A,(A)
04900 LAC TT,(TT)
05000 OPR: JFCL 17,.+1
05100 XCT 1(C) ;flt pt op
05200 JFCL 10,FLOOV
05300 JRST FLO1A
05400
05500 OPA5:
05600 FOO CAIE B,FLONUM
05700 JRST NUMV3
05800 PUSHJ P,FLOAT
05900 JRST OPR-1
06000
06100 OPB3:
06200 FOO CAIE B,FIXNUM
06300 JRST NUMV3
06400 SKIPA TT,(TT)
06500 OPB7: HRREI TT,-INUM0(B)
06600 FOO MOVEI B,FIXNUM
06700 FOO CAIE T,FLONUM
06800 JRST NUMV3
06900 LAC A,(A)
07000 EXCH A,TT
07100 PUSHJ P,FLOAT
07200 EXCH A,TT
07300 JRST OPR
00100 SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
00200
00300 FLATSIZE: HLLZS FLAT1
00400 MOVEI R,FLAT2
00500 PUSHJ P,PRINTA
00600 FLAT1: MOVEI A,X ;*
00700 JRST FIX1A
00800 FLAT2: AOS FLAT1
00900 POPJ P,
01000
01100
01200 %EXPLODE: SKIPA R,.+1
01300 EXPLODE: HRRZI R,EXPL1
01400 MOVSI AR1,AR1
01500 PUSHJ P,PRINTA
01600 JRST SUBS4
01700
01800 EXPL1: PUSH P,B
01900 PUSH P,C
02000 ANDI A,177
02100 CAIL A,"0"
02200 CAILE A,"9"
02300 JRST EXPL2
02400 ADDI A,INUM0-"0"
02500 JRST EXPL4
02600
02700 EXPL2: PUSH P,AR1
02800 PUSH P,TT
02900 PUSH P,T
03000 LSH A,35
03100 LAC C,SP
03200 PUSH C,A
03300 MOVEI AR1,1
03400 PUSHJ P,INTER0
03500 POP P,T
03600 POP P,TT
03700 POP P,AR1
03800 EXPL4: PUSHJ P,NCONS
03900 HLR B,AR1
04000 DAP A,(B)
04100 DIP A,AR1
04200 POP P,C
04300 JRST POPBJ
00100 READLIST: TDZA T,T
00200 MAKNAM: MOVNI T,1
00300 DAC T,NOINFG
00400 PUSH P,OLDCH
00500 SETZM OLDCH
00600 JUMPE A,NOLIST
00700 DAP A,MKNAM3
00800 MOVEI A,MKNAM2
00900 PUSHJ P,READ0
01000 LAPZ T,MKNAM3
01100 CAIE T,-1
01200 JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
01300 POP P,OLDCH
01400 POPJ P,
01500
01600 MKNAM2: PUSH P,B
01700 PUSH P,T
01800 PUSH P,TT
01900 MKNAM3: MOVEI TT,X
02000 JUMPE TT,MKNAM6
02100 CAIN TT,-1
02200 ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
02300 LAPZ B,(TT)
02400 DAP B,MKNAM3
02500 LIPZ A,(TT)
02600 CAIGE A,INUMIN
02700 JRST MKNAM5
02800 SUBI A,INUM0-"0"
02900 MKNAM4: POP P,TT
03000 POP P,T
03100 JRST POPBJ
03200
03300 MKNAM5: LIPZ A,(TT)
03400 FOO MOVEI B,PNAME
03500 PUSHJ P,GET
03600 LIPZ A,(A)
03700 LDB A,[POINT 7,(A),6]
03800 JRST MKNAM4
03900
04000 MKNAM6: MOVEI A," "
04100 HLLOS MKNAM3
04200 JRST MKNAM4
00100 SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
00200 EV3: LIPZ A,(AR1)
00300 FOO MOVEI B,VALUE
00400 PUSHJ P,GET
00500 JUMPE A,UNDFUN ;function object has no definition
00600 LAPZ A,(A)
00700 UBDPTR:
00800 FOO CAIN A,UNBOUND
00900 JRST UNDFUN
01000 LAPZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
01100 PUSHJ P,CONS
01200 JRST EVAL
01300
01400 OEVAL: AOJN T,AEVAL
01500 POP P,A
01600 EVAL: DAPZ A,AR1
01700 CAILE A,INUMIN
01800 JRST CPOPJ
01900 LIPZ T,(A)
02000 CAIN T,-1
02100 JRST EE1 ;x is atomic
02200 CAILE T,INUMIN
02300 JRST UNDFUN
02400 HLRO TT,(T)
02500 AOJE TT,EE2 ;car (x) is atomic
02600 JRST EXP3
02700
02800 EE1:
02900 EV5: LAPZ AR1,(AR1)
03000 JUMPE AR1,UNBVAR
03100 LIPZ TT,(AR1)
03200 FOO CAIE TT,FLONUM
03300 FOO CAIN TT,FIXNUM
03400 POPJ P,
03500 EVBIG: LAPZ AR1,(AR1) ;bignums know about me
03600 FOO CAIE TT,VALUE
03700 JRST EV5
03800 LIPZ AR1,(AR1)
03900 LAPZ AR1,(AR1)
04000 FOO CAIN AR1,UNBOUND
04100 JRST UNBVAR
04200 DAC AR1,A
04300 POPJ P,
00100 ALIST: SKIPE A,-1(P)
00200 PUSHJ P,NUMBERP
00300 DAC SP,SPSV
00400 JUMPN A,AEVAL7 ;number
00500 LAC C,SC2 ;bottom of spec pdl
00600 DAC C,AEVAL5#
00700 SETOM AEVAL2
00800 AEVAL8: LAC C,SP
00900 AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
01000 JRST AEVAL1 ;done
01100 POP C,T ;pointer for next block
01200 AEVAL4: CAMN C,T
01300 JRST AEVAL6 ;thru with block
01400 POP C,AR1
01500 MOVSS AR1
01600 PUSH SP,(AR1) ;save value cell
01700 HLRZM AR1,(AR1) ;store previous value in value cell
01800 DIP AR1,(SP) ;save pointer to spec pdl loc
01900 JRST AEVAL4
02000
02100 FNGUBD: EXCH A,(P) ;spec pdl pointer
02200 PUSHJ P,NUMVAL
02300 LAC D,A
02400 POP SP,TT ;end of block to rebind
02500 FNGUB2: CAMN SP,TT
02600 JRST POPAJ ;done
02700 POP SP,T
02800 MOVSS T ;pointer to value cell
02900 DIP T,(T)
03000 SKIPGE 1(D)
03100 AOBJN D,.-1 ;skip over spec pdl pointers
03200 PUSH D,(T) ;put value cell in spec pdl
03300 HLRZM T,(T) ;restore value cell
03400 JRST FNGUB2
03500
03600 AEVAL: PUSHJ P,ALIST
03700 POP P,A
03800 MOVEI A,UNBIND
03900 EXCH A,(P)
04000 JRST EVAL
00100 AEVAL1: SKIPGE AEVAL2
00200 SKIPN B,-1(P)
00300 JRST ABIND3 ;done with binding
00400
00500 ;alist binding
00600 LAC A,B
00700 PUSHJ P,REVERSE
00800 SKIPA
00900 ABIND2: LAC A,B
01000 LAPZ B,(A)
01100 LIPZ A,(A)
01200 LAPZ AR1,(A)
01300 LIPZ A,(A)
01400 PUSHJ P,BIND
01500 JUMPN B,ABIND2
01600 ABIND3: PUSH SP,SPSV
01700 POPJ P,
01800
01900 ;spec pdl binding
02000 AEVAL7: LAC A,-1(P)
02100 PUSHJ P,NUMVAL
02200 CLEARM AEVAL2
02300 DAC A,AEVAL5 ;point to unbind to
02400 JRST AEVAL8
02500
02600 AEVAL2: 0 ;0 for number, -1 for a-list *
00100
00200 EE2: LAPZ T,(T)
00300 JUMPE T,EV3
00400 LIPZ TT,(T)
00500 LAPZ T,(T)
00600 FOO CAIN TT,SUBR
00700 JRST ESB
00800 FOO CAIN TT,SAIBR
00900 JRST ESAIB
01000 FOO CAIN TT,LSUBR
01100 JRST EELS
01200 FOO CAIN TT,EXPR
01300 JRST AEXP
01400 FOO CAIN TT,FSUBR
01500 JRST EFS
01600 FOO CAIN TT,MACRO
01700 JRST EFM
01800 FOO CAIE TT,FEXPR
01900 JRST EE2
02000
02100 LIPZ T,(T)
02200 HLL T,(AR1)
02300 PUSH P,T
02400 LAPZ A,(A)
02500 TLO A,400000
02600 PUSH P,A
02700 MOVNI T,1
02800 JRST IAPPLY
02900
03000 AEXP: LIPZ T,(T)
03100 HLL T,(AR1)
03200 EXP3: PUSH P,T
03300 LAPZ A,(AR1)
03400 CILIST: JSP TT,ILIST
03500 EXP2: JRST IAPPLY
03600
03700 EFS: LIPZ T,(T)
03800 LAPZ A,(AR1)
03900 JRST (T)
00100 ESAIB: LAPZ A,(AR1)
00200 LIPZ T,(T)
00300 HLL T,(AR1)
00400 PUSH P,T
00500 JSP TT,ILIST
00600
00700 ;PUT DOWN LISP.
00800 DAC 0,LISPAC
00900 LAC 0,[XWD 1,LISPAC+1]
01000 BLT 0,LISPAC+17
01100 ;PICKUP SAIL.
01200 LAC 12,AC12
01300 LAC 16,AC16
01400 LAC 17,AC17
01500 LAC SAI41
01600 DAC JOB41
01700 LAC SAIAPR
01800 DAC JOBAPR
01900
02000 ;POP LISP STACK & AND PUSH INTO SAIL STACK.
02100 JRST .+NACS+1(T)
02200 POP P,A+4
02300 POP P,A+3
02400 POP P,A+2
02500 POP P,A+1
02600 POP P,A
02700 POP P,S
02800 DAC P,LISPAC+14
02900 MOVMS T
03000 SAIL1: JUMPE T,SAIL2
03100 LAC (T)
03200 SUBI INUM0
03300 DAC(T)
03400 PUSH 17,(T)
03500 SOJGE T,SAIL1
03600
03700 SAIL2: PUSHJ 17,(S) ;SAIL SUBROUTINE CALL.
03800 DAC 12,AC12
03900 DAC 16,AC16
04000 DAC 17,AC17
04100
04200 LAC [JSR UUOH]
04300 DAC JOB41
04400 MOVEI APRINT
04500 DAC JOBAPR
04600 LAC 0,LISPAC
04700 ADDI 1,INUM0
04800 LAC 14,LISPAC+14
04900 LAC 15,LISPAC+15
05000 LAC 16,LISPAC+16
05100 LAC 17,LISPAC+17
05200 POPJ P,
00100 ESB: LAPZ A,(AR1)
00200 UUOS2: LIPZ T,(T)
00300 HLL T,(AR1)
00400 PUSH P,T
00500 JSP TT,ILIST
00600 ESB1: JRST .+NACS+1(T)
00700 POP P,A+4
00800 POP P,A+3
00900 POP P,A+2
01000 POP P,A+1
01100 POPAJ: POP P,A
01200 POPJ P,
01300
01400 EFM: LIPZ T,(T)
01500 CALLF 1,(T)
01600 JRST EVAL
00100
00200 APPLY: MOVEI TT,AP2
00300 CAME T,[-3]
00400 JRST PDLARG
00500 DAC T,APFNG1#
00600 PUSHJ P,ALIST
00700 LAC T,APFNG1
00800 JSP TT,PDLARG
00900 PUSH P,C ;spec pdl pointer
01000 PUSH P,[FNGUBD]
01100 AP2: PUSH P,A
01200 MOVEI T,0
01300 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
01400 LIPZ C,(B)
01500 PUSH P,C ;push arg
01600 LAPZ B,(B)
01700 SOJA T,AP3
01800
01900 IAP4: JUMPGE D,TOOFEW ;special case for fexprs
02000 AOJN R,TOOFEW
02100 PUSH P,B
02200 LAC A,SP
02300 PUSHJ P,FIX1A
02400 EXCH A,(P)
02500 LAC B,A
02600 MOVNI R,2
02700 SOJA T,IAP5
02800
02900 FUNCT: PUSH P,A
03000 LAC A,SP
03100 PUSHJ P,FIX1A
03200 POP P,B
03300 LIPZ B,(B)
03400 PUSHJ P,XCONS
03500 FOO MOVEI B,FUNARG
03600 JRST XCONS
00100 APFNG: SOS T
00200 DAC T,APFNG1
00300 JSP TT,PDLARG ;get args and funarg list
00400 LAPZ A,(A)
00500 LAPZ D,(A) ;a-list pointer
00600 LIPZ A,(A) ;function
00700 HRLZ R,APFNG1 ;no. of args
00800 PUSH P,D
00900 PUSH P,[FNGUBD]
01000 JSP TT,ARGP1 ;replace args and fn name
01100 PUSH P,D ;a-list pointer
01200 PUSHJ P,ALIST ;set up spec pdl
01300 POP P,D
01400 AOS T,APFNG1
01500
01600 ;falls through
00100 ;falls in
00200
00300 IAPPLY: LAC C,T ;state of world at entrance
00400 ADDI C,(P) ;t has - number of args on pdl
00500 ILP1A: LAPZ B,(C) ;next pdl slot has function- poss fun name in lh
00600 CAILE B,INUMIN
00700 JRST UNDTAG
00800 LIPZ A,(B)
00900 CAIN A,-1
01000 JRST IAP1 ;fn is atomic
01100 FOO CAIN A,LAMBDA
01200 JRST IAPLMB
01300 FOO CAIN A,FUNARG
01400 JRST APFNG
01500 FOO CAIN A,LABEL
01600 JRST APLBL
01700 PUSH P,T
01800 LAC A,B
01900 PUSHJ P,EVAL
02000 POP P,T
02100 LAC C,T
02200 ADDI C,(P)
02300 ILP1B: DAC A,(C)
02400 JRST ILP1A
02500
02600 IAPXPR: LIPZ A,(B)
02700 JRST ILP1B
02800 IAP1: LAPZ B,(B)
02900 JUMPE B,IAP2
03000 LIPZ TT,(B)
03100 LAPZ B,(B)
03200 FOO CAIN TT,EXPR
03300 JRST IAPXPR
03400 FOO CAIN TT,LSUBR
03500 JRST IAP6
03600 FOO CAIE TT,SUBR
03700 JRST IAP1
03800 LIPZ B,(B)
03900 DAC B,(C)
04000 JRST ESB1
00100 IAPLMB: LAPZ B,(B)
00200 LIPZ TT,(B)
00300 DAC SP,SPSV
00400 LAPZ B,(B)
00500 LIPZ D,(TT)
00600 CAIN D,-1
00700 JUMPN TT, IAP3
00800 LAC R,T
00900 IPLMB1: JUMPE T,IPLMB2 ;no more args
01000 JUMPE TT,TOMANY ;too many args supplied
01100 IAP5: LIPZ A,(TT)
01200 MOVEI AR1,1(T)
01300 ADD AR1,P
01400 HLLZ D,(AR1)
01500 DIP A,(AR1)
01600 LAPZ TT,(TT)
01700 AOJA T,IPLMB1
00100
00200
00300 IPLMB2: JUMPN TT,IAP4 ;too few args supplied
00400 JUMPE R,IAP69
00500 IPLMB4: POP P,AR1
00600 LIPZ A,AR1
00700 AOJG R,IPLMB3
00800 PUSHJ P,BIND
00900 JRST IPLMB4
01000 IPLMB3: SKIPE BACTRF
01100 JRST APBK1
01200 APBK2: LIPZ A,(B)
01300 PUSH SP,SPSV
01400 PUSHJ P,EVAL
01500 JRST UNBIND
01600
01700 IAP69: POP P,(P)
01800 LIPZ A,(B)
01900 JRST EVAL
02000
02100 APBK1: HRRI AR1,CPOPJ
02200 TLNE AR1,-1
02300 PUSH P,AR1
02400 JRST APBK2
02500 IAP6: MOVEI TT,CPOPJ
02600 DAC TT,(C)
02700 LIPZ B,(B)
02800 JRST (B)
02900
03000 APLBL: DAC SP,SPSV
03100 LAPZ B,(B)
03200 LIPZ A,(B)
03300 LAPZ B,(B)
03400 LIPZ AR1,(B)
03500 DAC AR1,(C)
03600 PUSHJ P,BIND
03700 MOVEI A,APLBL1
03800 EXCH A,-1(C)
03900 EXCH A,LBLAD#
04000 HRLI A,LBLAD
04100 PUSH SP,A
04200 PUSH SP,SPSV
04300 JRST IAPPLY
04400 APLBL1: PUSH P,LBLAD
04500 JRST SPECSTR
04600
04700 IAP2: LAPZ A,(C)
04800 FOO MOVEI B,VALUE
04900 PUSHJ P,GET
05000 JUMPE A,UNDTAG
05100 LAPZ A,(A)
05200 FOO CAIN A,UNBOUND
05300 JRST UNDTAG
05400 JRST ILP1B
05500
05600 IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
05700 LAC A,TT
05800 PUSHJ P,BIND
05900 PUSH P,ARG
06000 SUBI C,INUM0
06100 DAP C,ARG
06200 PUSH SP,SPSV
06300 LIPZ A,(B)
06400 PUSHJ P,EVAL
06500 LAPZ T,ARG
06600 POP P,ARG
06700 SUBI T,1-INUM0(P)
06800 HRLI T,-1(T)
06900 ADD P,T
07000 JRST UNBIND
07100
07200 ARG: LAPZ A,X(A) ;*
07300 POPJ P,
07400
07500 SETARG: DAPZ B,@ARG
07600 JRST PROG2
00100 BIND: PUSH P,B
00200 DAPZ A,BIND3#
00300 BIND2:
00400 FOO MOVEI B,VALUE ;bind atom in a to value in ar1,save
00500 PUSHJ P,GET ;old binding on s pdl
00600 JUMPE A,BIND1 ;add value cell
00700 PUSH SP,(A)
00800 DIP A,(SP)
00900 DAPZ AR1,(A)
01000 POPBJ: POP P,B
01100 POPJ P,
01200
01300 BIND1:
01400 FOO MOVEI B,UNBOUND
01500 MOVEI A,0
01600 PUSHJ P,CONS
01700 LAPZ B,@BIND3
01800 PUSHJ P,CONS
01900 FOO MOVEI B,VALUE
02000 PUSHJ P,XCONS
02100 DAP A,@BIND3
02200 LAC A,BIND3
02300 JRST BIND2
02400
02500 UBD: CAMN SP,B
02600 POPJ P,
02700 PUSHJ P,UNBIND
02800 JRST UBD
02900
03000 UNBIND:
03100 SPECSTR: LAC TT,(SP)
03200 SUB SP,[XWD 1,1]
03300 JUMPGE TT,.-2 ;syncronize stack
03400 UNBND1: CAMN SP,TT
03500 POPJ P,
03600 POP SP,T
03700 MOVSS T
03800 HLRZM T,(T)
03900 JRST UNBND1
04000
04100 SPECBIND: LAC TT,SP
04200 SPEC1: LDB R,[POINT 13,(T),ACFLD]
04300 CAILE R,17
04400 JRST SPECX
04500 SKIPE R
04600 LAC R,(R)
04700 EXCH R,@(T)
04800 HRL R,(T)
04900 PUSH SP,R
05000 AOJA T,SPEC1
05100 SPECX: PUSH SP,TT
05200 JRST (T)
05300
05400 ;random special case compiler run time routines
05500
05600 %AMAKE: PUSH P,A ;make alist for fsubr that requires it
05700 LAC A,SP
05800 PUSHJ P,FIX1A
05900 LAC B,A
06000 JRST POPAJ
06100
06200 %UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
06300 STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
06400 LAPZ R,(P)
06500 PUSHJ P,ERSUB3
06600 JRST ERREND
06700
06800 %LCALL: MOVN A,T ;set up routine for compile lsubr
06900 ADDI A,INUM0
07000 ADDI T,(P)
07100 PUSH P,T
07200 PUSHJ P,(3)
07300 POP P,T
07400 SUBI T,(P)
07500 HRLI T,-1(T)
07600 ADD P,T
07700 POPJ P,
00100 SUBTTL ARRAY SUBROUTINES --- PAGE 14
00200
00300 ARRERR=-1
00400
00500 ARRAY: PUSHJ P,ARRAYS
00600 HRRI AR2A,1(R)
00700 LAC A,AR2A
00800 PUSH R,[0]
00900 AOBJN A,.-1
01000 ARREND: LAC A,BPPNR#
01100 DAC AR2A,-1(A)
01200 MOVEI A,INUM0+1(R)
01300 FOO DAC A,VBPORG
01400 POPJ P,
01500
01600 ARRAYS: PUSH P,A
01700 FOO LAC A,VBPORG
01800 SUBI A,INUM0
01900 DAC A,BPPNR
02000 FOO LAC A,VBPEND
02100 MOVNI A,-INUM0-2(A)
02200 ADD A,BPPNR ;bporg-bpend+2
02300 DIP A,BPPNR
02400 POP P,A
02500 LAPZ AR1,(A) ;(cdr l)
02600 LIPZ A,(A) ;(car l)name
02700 LAPZ B,BPPNR
02800 ADDI B,2
02900 FOO MOVEI C,SUBR
03000 PUSHJ P,PUTPROP
03100 LIPZ A,(AR1) ;(cadr l)mode
03200 PUSH P,AR1
03300 PUSHJ P,EVAL ;eval mode
03400 POP P,AR1
03500 DAC A,AMODE#
03600 MOVEI C,44
03700 JUMPE A,ARRY1
03800 MOVEI C,-INUM0(A)
03900 CAILE A,INUMIN
04000 JRST ARRY1
04100 MOVEI C,22
04200 LAPZ A,BPPNR
04300 LAC B,GCMKL
04400 PUSHJ P,CONS
04500 DAC A,GCMKL
04600 ARRY1: DAC C,BSIZE#
04700 MOVEI A,44
04800 IDIV A,C
04900 DAC A,NBYTES#
05000 LAPZ A,(AR1) ;(cddr l)bound pair list
05100 JSP TT,ILIST
05200 AOS R,BPPNR
05300 MOVEI AR1,1 ;ar1 is array size
05400 MOVEI AR2A,0 ;ar2a is cumulative residue
05500 AOJGE T,ARRYS ;single dimension
05600 MOVEI D,A-1
05700 SUB D,T ;d is next ac for array code generation
05800 ARRY2: PUSHJ P,ARRB0
05900 TLC TT,(IMULI)
06000 DPB D,[POINT 4,TT,ACFLD]
06100 PUSH R,TT
06200 CAIN D,A
06300 JRST ARRY3
06400 MOVSI TT,(ADD)
06500 ADDI TT,1(D)
06600 DPB D,[POINT 4,TT,ACFLD]
06700 PUSH R,TT
06800 SOJA D,ARRY2
06900
07000 ARRB0: POP P,TT
07100 EXCH TT,(P)
07200 CAILE TT,INUMIN
07300 JRST ARRB1
07400 LIPZ A,(TT)
07500 LAPZ TT,(TT)
07600 SUBI TT,(A)
07700 ADDI TT,1
07800 JRST ARRB2
07900
08000 ARRB1: MOVEI A,INUM0
08100 SUB TT,A
08200 ARRB2: IMUL A,AR1
08300 IMULB AR1,TT
08400 ADDM A,AR2A
08500 POPJ P,
08600
08700 ARRY3: PUSH R,[ADD A,B]
08800 ARRYS: PUSHJ P,ARRB0
08900 LAPZ TT,BPPNR
09000 DAC AR2A,(TT)
09100 HRLI TT,(SUB A,)
09200 PUSH R,TT
09300 PUSH R,[JUMPL A,ARRERR]
09400 LAC TT,AR1
09500 HRLI TT,(CAIL A,)
09600 PUSH R,TT
09700 PUSH R,[JRST ARRERR]
09800 IDIV AR1,NBYTES ;calc #words in array
09900 SKIPE AR2A ;correct for remainder non-zero
10000 ADDI AR1,1
10100 LAC TT,NBYTES
10200 SOJE TT,ARRY6
10300 ADDI TT,1
10400 HRLI TT,(IDIVI A,)
10500 PUSH R,TT
10600 MOVN TT,BSIZE
10700 LSH TT,14
10800 HRLI TT,(IMULI B,)
10900 PUSH R,TT
11000 MOVEI TT,44+200
11100 SUB TT,BSIZE
11200 LSH TT,6
11300 ARRY6: ADD TT,BSIZE
11400 LSH TT,6
11500 SKIPE AR2A,AMODE
11600 CAIL AR2A,INUMIN
11700 ADDI TT,40 ;mode not = t
11800 TLC TT,(HRLZI C,)
11900 PUSH R,TT
12000 MOVEI TT,4(R)
12100 HRLI TT,(ADDI C,(A))
12200 PUSH R,TT
12300 PUSH R,[LDB A,C]
12400 HRLZI AR2A,(POPJ P,)
12500 SKIPN TT,AMODE
12600 LAC AR2A,[JRST FLO1A]
12700 CAIL TT,INUMIN
12800 LAC AR2A,[JRST FIX1A]
12900 PUSH R,AR2A
13000 MOVS AR2A,AR1
13100 MOVNS AR2A
13200 POPJ P,
13300
00100 EXARRAY: PUSH P,A
00200 LIPZ A,(A)
00300 PUSHJ P,GETSYM
00400 JUMPE A,POPAJ
00500 PUSHJ P,NUMVAL
00600 EXCH A,(P)
00700 PUSHJ P,ARRAYS
00800 POP P,A
00900 DAP A,-2(R)
01000 HRR AR2A,A
01100 JRST ARREND
01200
01300 STORE: PUSH P,A
01400 PUSHJ P,CADR
01500 PUSHJ P,EVAL ;value to store
01600 EXCH A,(P)
01700 LIPZ A,(A)
01800 PUSHJ P,EVAL ;byte pointer returned in c
01900 POP P,A
02000 NSTR: PUSH P,A
02100 TLNE C,40
02200 PUSHJ P,NUMVAL ;numerical array
02300 DPB A,C
02400 POP P,A
02500 POPJ P,
00100 SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
00200
00300 BOOLE: LAC TT,T
00400 ADDI TT,2(P)
00500 LAC A,-1(TT)
00600 SUBI A,INUM0
00700 DPB A,[POINT 4,BOOLI,OPFLD-2]
00800 PUSHJ P,BOOLG
00900 LAC C,A
01000 BOOLL: PUSHJ P,BOOLG
01100 BOOLI: CLEARB C,A
01200 JRST BOOLL
01300
01400 BOOLG: CAIL TT,(P)
01500 JRST BOOL1
01600 LAC A,(TT)
01700 PUSHJ P,NUMVAL
01800 AOJA TT,CPOPJ
01900
02000 BOOL1: HRLI T,-1(T)
02100 ADD P,T
02200 POP P,B
02300 JRST FIX1A
02400
02500 EXAMINE: LAC A,-INUM0(A)
02600 JRST FIX1A
02700
02800 DEPOSIT: MOVEI C,-INUM0(A)
02900 LAC A,B
03000 PUSHJ P,NUMVAL
03100 DAC A,(C)
03200 JRST MAKNUM
03300
03400 LSH: MOVEI C,-INUM0(B)
03500 PUSHJ P,NUMVAL
03600 LSH A,(C)
03700 JRST FIX1A