github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-22 17:08:15 +00:00
Code Issues Releases Wiki Activity
Files
098ab00faa7ea30890e6a17627ecba6cb738392e
PDP-10.its/src/mudsys/primit.316
Adam Sampson a81db26a7a Rename to ITS conventions. 
MIDAS and Muddle source get version numbers (as in the 1973 Muddle
source); the build files don't.
2018-04-25 09:32:25 +01:00

2830 lines
52 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
RELOCATABLE
.INSRT MUDDLE >
.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP,LSTUF,PVSTOR,SPSTOR
.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP
.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0
.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM
.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST
.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK
.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY
.GLOBAL TMPLNT,BADTPL,ISTRCM,PTYPE,CIGVAL,MAKTUP,CSBSTR,TMATCH
; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
F==PVP
PRMTYP:
REPEAT NUMSAT+1,[0] ;INITIALIZE TABLE TO ZEROES
IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
LOC PRMTYP+S!A
P!A==.IRPCN+1
P!A
TERMIN
PTMPLT==PBYTE+1
; FUDGE FOR STRUCTURE LOCATIVES
IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]
[LOCT,TMPLT],[LOCB,BYTE]]
IRP B,C,[A]
LOC PRMTYP+S!B
P!B==P!C,,0
P!B
.ISTOP
TERMIN
TERMIN
LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE
PNWORD
LOC PRMTYP+NUMSAT+1
PNUM==PTMPLT+1
; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
DEFINE PRDISP NAME,DEFAULT,LIST
TBLDIS NAME,DEFAULT,[LIST]PNUM,400000
TERMIN
; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR
CAIN A,TILLEG ;LOSE IF ILLEGAL
JRST ILLCHOS
PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
CAIE A,SLOCA
CAIN A,SARGS ;SPECIAL HAIR FOR ARGS
PUSHJ P,CHARGS
CAIN A,SFRAME
PUSHJ P,CHFRM
CAIN A,SLOCID
PUSHJ P,CHLOCI
PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE
CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
SKIPA A,[PTMPLT]
MOVE A,PRMTYP(A) ;GET PRIM TYPE,
POPJ P,
; COMPILERS CALL TO ABOVE (LESS CHECKING)
CPTYPE: PUSHJ P,SAT
MOVEI 0,(A)
CAILE A,NUMSAT
SKIPA A,[PTMPLT]
MOVE A,PRMTYP(A)
POPJ P,
MFUNCTION SORT,SUBR
ENTRY
; HACK TO DYNAMICALLY LOAD SORT
MOVE B,MQUOTE SORTX
PUSHJ P,CIGVAL
PUSH TP,A
PUSH TP,B ; PUSH ON FUNCTION FOR APPLY
MOVE A,AB ; PUSH ARGS TO SORT ONTO STACK
JUMPE A,DONPSH
PUSH TP,(A)
AOBJN A,.-1
DONPSH: HLRE A,AB ; GET COUNT
MOVNS A
ADDI A,2
ASH A,-1 ; # OF ARGS
ACALL A,APPLY
JRST FINIS
MFUNCTION SUBSTRUC,SUBR
ENTRY
JUMPGE AB,TFA ;need at least one arg
CAMGE AB,[-10,,0] ;NO MORE THEN 4
JRST TMA
HLRE A,AB ; GET NEGATIVE LENGTH IN A
MOVNS A ; SET UP LENGTH ARG TO SUBSTRUC
ASH A,-1
MOVE B,AB ; AOBJN POINTER FOR LOOP
PUSH TP,(B) ; PUSH ON ARGS
AOBJN B,.-1
PUSHJ P,CSBSTR ; GO TO INTERNAL ROUTINE
JRST FINIS
; VARIOUS OFFSETS INTO PSTACK
PRTYP==0
LNT==0
NOARGS==-1
; VARIOUS OFFSETS INTO TP STACK
OBJ==-7
RSTR==-5
LNT==-3
NOBJ==-1
; THIS STARTS THE MAIN ROUTINE
CSBSTR: SUBM M,(P) ; FOR RSUBRS
JSP E,@PTBL(A)
MOVEI B,OBJ(TP)
PUSH P,A
PUSHJ P,PTYPE ; get primtype in A
PUSH P,A
JRST @TYTBL(A)
PTBL: SETZ WNA
SETZ PUSH6
SETZ PUSH4
SETZ PUSH2
SETZ PUSH0
PUSH6: PUSH TP,[0]
PUSH TP,[0]
PUSH4: PUSH TP,[0]
PUSH TP,[0]
PUSH2: PUSH TP,[0]
PUSH TP,[0]
PUSH0: JRST (E)
RESSUB: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
CAIN D,1 ; IF 1 THEN JUST COPY
JRST @COPYTB(A)
GETYP B,RSTR(TP) ; GET TYPE OF REST ARGUMENT
CAIE B,TFIX ;IF FIX OK
JRST WRONGT
MOVEI E,(A)
MOVE A,OBJ(TP)
MOVE B,OBJ+1(TP) ; GET OBJECT
SKIPGE C,RSTR+1(TP) ; GET REST ARGUMENT
JRST OUTRNG
PUSHJ P,@MRSTBL(E)
PUSH TP,A ; type
PUSH TP,B ; put rested sturc on stack
JRST ALOCOK
PRDISP TYTBL,IWTYP1,[[PARGS,RESSUB],[P2WORD,RESSUB],[P2NWORD,RESSUB]
[PNWORD,RESSUB],[PCHSTR,RESSUB],[PBYTE,RESSUB]]
PRDISP MRSTBL,IWTYP1,[[PARGS,AREST],[P2WORD,LREST],[P2NWORD,VREST]
[PNWORD,UREST],[PCHSTR,SREST],[PBYTE,BREST]]
PRDISP COPYTB,IWTYP1,[[PARGS,CPYVEC],[P2WORD,CPYLST],[P2NWORD,CPYVEC]
[PNWORD,CPYUVC],[PCHSTR,CPYSTR],[PBYTE,CPYBYT]]
PRDISP ALOCTB,IWTYP1,[[PARGS,ALVEC],[P2WORD,ALLIST],[P2NWORD,ALVEC]
[PNWORD,ALUVEC],[PCHSTR,ALSTR],[PBYTE,ALBYT]]
; HERE WE HAVE RESTED STRUCTURE ON TOP OF STACK
ALOCFX: MOVE B,(TP) ; missing 3rd arg aloc for "rest" of struc
MOVE C,-1(TP)
MOVE A,(P)
PUSH P,[377777,,-1]
PUSHJ P,@LENTBL(A) ; get length of rested struc
SUB P,[1,,1]
POP P,C
MOVE A,B ; # of elements needed
JRST @ALOCTB(C)
; HERE WE HAVE RESTED STRUCTURE ON THE TOP OF THE STACK
ALOCOK: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
CAIG D,2 ; SKIP IF NOT EXACTLY 3 ARGS
JRST ALOCFX
GETYP C,LNT-2(TP) ; GET THE LENGTH ARGUMENT
CAIE C,TFIX ; OK IF TYPE FIX
JRST WRONGT
POP P,C
SKIPL A,LNT-1(TP) ; GET LENGTH
JRST @ALOCTB(C) ; DO ALLOCATION
JRST OUTRNG
CPYVEC: HLRE A,OBJ+1(TP) ; USE WHEN ONLY ONE ARG
MOVNS A ; LENGTH ARG IS LENGTH OF STRUCTURE
ASH A,-1 ; # OF ELEMENTS FOR ALLOCATION
PUSH TP,OBJ(TP)
SUB P,[1,,1]
PUSH TP,OBJ(TP) ; REPUSH ARGS
ALVEC: PUSH P,A ; SAVE LENGTH
ASH A,1
HRLI A,(A)
ADD A,(TP)
CAIL A,-1 ; CHK FOR OUT OF RANGE
JRST OUTRNG
MOVE D,NOARGS(P)
CAILE D,3 ; SKIP IF WE GET VECTOR
JRST ALVEC2 ; USER SUPPLIED VECTOR
MOVE A,(P)
PUSHJ P,IBLOK1
ALVEC1: MOVE A,(P) ; # OF WORDS TO ALLOCATE
MOVE C,B ; SAVE VECTOR POINTER
JUMPE A,ALEVC4
ASH A,1 ; TIMES 2
HRLI A,(A)
ADD A,B ; PTING TO FIRST DOPE WORD -ALLOCATED
CAIL A,-1
JRST OUTRNG
SUBI A,1 ; ptr to last element of the block
MOVE D,NOARGS(P)
CAILE D,3
CAMGE B,(TP) ; SKIP IF BACKWARDS BLT IS NEEDED
JRST ALEVC3
HRRZ 0,(TP)
ADD 0,-4(TP)
ADD 0,-4(TP) ; FIND END OF DEST
CAIGE 0,(B) ; SEE IF BBLT IS NEEDED
JRST ALEVC3
PUSHJ P,BBLT ; BLT IT
JRST ALEVC4
ALEVC3: HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space
BLT B,(A)
MOVE B,C
ALEVC4: MOVE D,NOARGS(P)
CAIE D,4
JRST ALEVC5
MOVE A,NOBJ-2(TP)
JRST EXSUB
ALEVC5: MOVSI A,TVEC
JRST EXSUB
; RESTED OBJECT ON TOP OF STACK
ALVEC2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
CAIE 0,TARGS
CAIN 0,TVEC
SKIPA
JRST WTYP
HLRE A,NOBJ-1(TP) ; CHECK SIZE
MOVNS A
ASH A,-1 ; # OF ELEMENTS
CAMGE A,(P) ; SKIP IF BIG ENOUGH
JRST OUTRNG
MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
JRST ALVEC1
CPYUVC: HLRE A,OBJ+1(TP) ;# OF ELEMENTS FOR ALLOCATION
MOVNS A
PUSH TP,(B)
PUSH TP,1(B)
SUB P,[1,,1]
ALUVEC: PUSH P,A
HRLI A,(A)
ADD A,(TP) ; PTING TO DOPE WORD OF ORIG VEC
CAIL A,-1
JRST OUTRNG
MOVE D,NOARGS(P)
CAILE D,3
JRST ALUVE2
MOVE A,(P)
PUSHJ P,IBLOCK
ALUVE1: MOVE A,(P) ; # of owrds to allocate
JUMPE A,ALUEV4
HRLI A,(A)
ADD A,B ; LOCATION O FIRST ALLOCATED DOPE WORD
HLR E,OBJ-1(TP) ; # OF ELEMENTS IN UVECTOR
MOVNS E
ADD E,OBJ-1(TP) ; LOCATION OF FIRST DOPE WORD FOR SOURCE
GETYP E,(E) ; GET UTYPE
MOVE D,NOARGS(P)
CAIE D,4
PUTYP E,(A) ; DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC
CAILE D,3
CAIN 0,(E) ; 0 HAS USER UVEC UTYPE
JRST .+2
JRST WRNGUT
CAIL A,-1
JRST OUTRNG
MOVE D,NOARGS(P)
CAILE D,3
CAMGE B,(TP) ; SKIP IF NEEDS BACKWARDS BLT
JRST ALUEV3
HRRZ 0,(TP)
ADD 0,-4(TP)
CAIGE 0,(B)
JRST ALUEV3
SUBI A,1
PUSHJ P,BBLT
JRST ALUEV4
ALUEV3: MOVE C,B ; SAVE POINTER TO FINAL GUY
HRL C,(TP) ; BUILD BLT POINTER
BLT C,-1(A)
ALUEV4: MOVSI A,TUVEC
JRST EXSUB
; BACKWARDS BLTTER
; A==LAST WORD DEST (TP)==FIRST WORD DEST B==FIRST WORD SOURCE
BBLT: SUBI A,-1(B)
MOVE E,A ; SAVE ADDITION
HRLZS A ; SWAP AND ZERO
HRR A,(TP)
ADDI A,-1(E)
MOVEI C,(B) ; SET UP DEST WORD
SUBI C,(A) ; CALC DIFF
ADDI C,-1(E) ; ADD TO GET TO END
HRLI C,A ; SET UP INDIRECT
POP A,@C ; BLT
TLNE A,-1 ; SKIP IF DONE
JRST .-2
POPJ P, ; EXIT
ALUVE2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
CAIE 0,TUVEC
JRST WTYP
HLRE A,NOBJ-1(TP) ; CHECK SIZE
MOVNS A
CAMGE A,(P) ; SKIP IF BIG ENOUGH
JRST OUTRNG
MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
HLRE A,B
SUBM B,A
GETYP 0,(A) ; GET UTYPE OF USER UVECTOR
JRST ALUVE1
ALBYT: MOVSI C,TBYTE
JRST ALSTRX
CPYBYT: SKIPA C,$TBYTE
CPYSTR: MOVSI C,TCHSTR
HRR A,OBJ(TP)
PUSH TP,(B) ; ALSTR EXPECTS STRING IN TP
PUSH TP,1(B)
SUB P,[1,,1]
JRST .+2
ALSTR: MOVSI C,TCHSTR
ALSTRX: PUSH P,C ; SAVE FINAL TYPE
PUSH P,A ; LENGTH
HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR
CAIGE 0,(A)
JRST OUTRNG
CAILE D,3
JRST ALSTR2
LDB C,[300600,,(TP)]
MOVEI B,36.
IDIVI B,(C) ; B BYT PER WD, C XTRA BITS
ADDI A,-1(B)
IDIVI A,(B)
PUSH P,C
PUSHJ P,IBLOCK ;ALLOCATE SPACE
HLL B,(TP)
POP P,C
DPB C,[360600,,B]
SUBI B,1
MOVEM B,-2(TP)
MOVE A,(P) ; # OF CHARS TO A
HLL A,-1(P)
MOVEM A,-3(TP)
JUMPN A,SSTR1
ALSTR9: SUB TP,[4,,4]
JRST ALSTR8
ALSTR1: HLL A,-2(P) ; GET TYPE
HRRZ C,B ; SEE IF WE WILL OVERLAP
HRRZ D,(TP) ; GET RESTED STRING
CAIGE C,(D) ; IF C > B THE A CHANCE
JRST SSTR
MOVEI C,-1(TP) ; GO TO BYTDOP
PUSHJ P,BYTDOP
HRRZ B,-2(TP) ; IF B < A THEN OVERLAP
CAILE B,(A)
JRST SSTR
HRRZ A,-4(TP) ; GET LENGTH IN A
MOVEI B,0 ; START LENGTH COUNT
; ORIGINAL STRING IS ON THE TOP OF THE STACK
CLOOP1: INTGO
PUSH P,[0] ; STORE CHARS ON STACK
MOVSI E,(<440000,,(P)>) ; SETUP BYTE POINTER
LDB 0,[300600,,(TP)]
DPB 0,[300600,,E]
CLOOP: IBP E ; BUMP IT
TRNE E,-1 ; WORD FULL
AOJA B,CLOOP1 ; PUSH NEW ONE
ILDB 0,(TP) ; GET A CHARACTER
SOS -1(TP) ; DECREMENT CHARACTER COUNT
DPB 0,E
SOJN A,CLOOP ; ANY MORE?
SUB TP,[2,,2]
MOVEI C,(P)
PUSH P,B ; SAVE B
SUBI C,(B)
MOVE A,-2(TP) ; GET COUNT
MOVE B,(TP)
HRLI C,440000 ; MAKE IT LOOK LIKE A BYTE PTR
LDB 0,[300600,,(TP)]
DPB 0,[300600,,C]
CLOOP3: ILDB D,C ; GET NEW CHARACTER
IDPB D,B ; DEPOSIT CHARACTER
SOJG A,CLOOP3
POP P,A
SUBI P,(A)
HRLZS A
SUB P,A ; CLEAN OFF STACK
POP TP,B ;BYTE PTR TO COPY
SUB P,[1,,1]
ALST10: SUB TP,[1,,1] ; CLEAN OFF STACK
ALSTR8: POP P,A ;# FO ELEMENTS
HLL A,(P)
SUB TP,[6,,6]
JRST EXSUB1
; ROUTINE TO DO FAST TRANSFER FOR NON SHARING STRINGS
SSTR: MOVE A,-4(TP) ; GET # OF ELEMENTS INTO A
MOVE B,-2(TP)
SSTR1: POP TP,C
SUB TP,[1,,1]
HRRZS A
SSTR2: ILDB D,C
IDPB D,B
SOJG A,SSTR2
POP TP,B
JRST ALST10
ALSTR2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
MOVSS 0
CAME 0,-1(P)
JRST WTYP
HRRZ A,NOBJ-2(TP)
CAMGE A,(P) ; SKIP IF BIG ENOUGH
JRST OUTRNG
EXCH A,(P)
MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
JUMPE A,ALSTR9
JRST ALSTR1
; HERE TO COPY A LIST
CPYLST: SKIPN OBJ+1(TP)
JRST ZEROLT
PUSHJ P,CELL2
POP P,C
HRLI C,TLIST ; TP JUNK FOR GAR. COLLECTOR
PUSH TP,C ; TYPE
PUSH TP,B ; VALUE -PTR TO NEW LIST
PUSH TP,C ; TYPE
MOVE C,OBJ-2(TP) ; PTR TO FIRST ELEMENT OF ORIG. LIST
REPLST: MOVE D,(C)
MOVE E,1(C) ; GET LIST ELEMENT INTO ALOC SPACE
HLLM D,(B)
MOVEM E,1(B) ; PUT INTO ALLOCATED SPACE
HRRZ C,(C) ; UPDATE PTR
JUMPE C,CLOSWL ; END OF LIST?
PUSH TP,B
PUSHJ P,CELL2
POP TP,D
HRRM B,(D) ; LINK ALLOCATED LIST CELLS
JRST REPLST
CLOSWL: MOVE A,-2(TP) ; GET LIST
MOVE B,-1(TP)
SUB TP,[11.,,11.]
LEXIT: SUB P,[1,,1]
JRST MPOPJ
ALLIST: PUSH P,A
MOVE D,NOARGS(P)
CAILE D,3 ; SKIP IF WE BUILD LIST
JRST CPYLS2
JUMPE A,ZEROL1
ASH A,1 ; TIMES 2
PUSHJ P,CELL
POP P,A ; # OF ELEMENTS
PUSH P,B ; ptr to allocated list
POP TP,C ; ptr to orig list
JRST ENTCOP
COPYL: ADDI B,2
HRRM B,-2(B) ; LINK ALOCATED LIST CELLS
ENTCOP: JUMPE C,OUTRNG
MOVE D,(C)
MOVE E,1(C) ; get list element into D+E
HLLM D,(B)
MOVEM E,1(B) ; put into allocated space
HRRZ C,(C) ; update ptrs
SOJG A,COPYL ; finish transfer?
CLOSEL: POP P,B
MOVE A,(TP)
SUB TP,[9.,,9.]
JRST LEXIT
ZEROL1: SUB TP,[2,,2]
ZEROLT: MOVSI A,TLIST
MOVEI B,0
SUB TP,[8,,8]
JRST EXSUB1
CPYLS2: GETYP 0,NOBJ-2(TP)
CAIE 0,TLIST
JRST WTYP
MOVE B,NOBJ-1(TP) ; GET DEST LIST
MOVE C,(TP)
JUMPE A,CPYLS3
CPYLS4: JUMPE B,OUTRNG
JUMPE C,OUTRNG
MOVE D,1(C)
MOVEM D,1(B)
GETYP 0,(C)
HRLM 0,(B)
HRRZ B,(B)
HRRZ C,(C)
SOJG A,CPYLS4
CPYLS3: MOVE D,-2(TP)
MOVE B,NOBJ-1(TP)
MOVSI A,TLIST
; HERE TO EXIT
EXSUB: SUB TP,[10.,,10.]
EXSUB1: SUB P,[2,,2]
JRST MPOPJ
; PROCESS TYPE ILLEGAL
ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE
CAIN B,TARGS ;WAS IT ARGS?
JRST ILLAR1
CAIN B,TFRAME ;A FRAME?
JRST ILFRAM
CAIN B,TLOCD ;A LOCATIVE TO AN ID
JRST ILLOC1
LSH B,1 ;NONE OF ABOVE LOOK IN TABLE
ADDI B,TYPVEC+1
PUSH TP,$TATOM
PUSH TP,EQUOTE ILLEGAL
PUSH TP,$TATOM
PUSH TP,(B) ;PUSH ATOMIC NAME
MOVEI A,2
JRST CALER ;GO TO ERROR REPORTER
; CHECK AN ARGS POINTER
CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK
JUMPN B,CPOPJ
ILLAR1: ERRUUO EQUOTE ILLEGAL-ARGUMENT-BLOCK
ICHARG: PUSH P,A ;SAVE SOME ACS
PUSH P,B
PUSH P,C
SKIPN C,1(B) ;GET POINTER
JRST ILLARG ; ZERO POINTER IS ILLEGAL
HLRE A,C ;FIND ASSOCIATED FRAME
SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER
GETYP A,(C) ;GET TYPE OF NEXT GOODIE
CAIN A,TCBLK
JRST CHARG1
CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO
CAIN A,TINFO
JRST CHARG1 ;WINNER
JRST ILLARG
CHARG1: CAIN A,TINFO ;POINTER TO FRAME?
ADD C,1(C) ;YES, GET IT
CAIE A,TINFO ;POINTS TO ENTRT?
MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME
HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME
HRRZ B,(B) ;AND ARGS TIME
CAIE B,(C) ;SAME?
ILLARG: SETZM -1(P) ; RETURN ZEROED B
POPBCJ: POP P,C
POP P,B
POP P,A
POPJ P, ;GO GET PRIM TYPE
; CHECK A FRAME POINTER
CHFRM: PUSHJ P,CHFRAM
JUMPN B,CPOPJ
ILFRAM: ERRUUO EQUOTE ILLEGAL-FRAME
CHFRAM: PUSH P,A ;SAVE SOME REGISTERS
PUSH P,B
PUSH P,C
HRRZ A,(B) ; GE PVP POINTER
HLRZ C,(A) ; GET LNTH
SUBI A,-1(C) ; POINT TO TOP
MOVE PVP,PVSTOR+1
CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS
MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED
HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC
HRRZ C,1(B) ;GET POINTER PART
CAILE C,1(A) ;STILL WITHIN STACK
JRST BDFR
HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK
CAIN A,TCBLK
JRST .+3
CAIE A,TENTRY
JRST BDFR
HLRZ A,1(B) ;GET TIME FROM POINTER
HLRZ C,OTBSAV(C) ;AND FROM FRAME
CAIE A,(C) ;SAME?
BDFR: SETZM -1(P) ; RETURN 0 IN B
JRST POPBCJ ;YES, WIN
; CHECK A LOCATIVE TO AN IDENTIFIER
CHLOCI: PUSHJ P,ICHLOC
JUMPN B,CPOPJ
ILLOC1: ERRUUO EQUOTE ILLEGAL-LOCATIVE
ICHLOC: PUSH P,A
PUSH P,B
PUSH P,C
HRRZ A,(B) ;GET TIME FROM POINTER
JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME
HRRZ C,1(B) ;POINT TO STACK
CAMLE C,VECTOP
JRST ILLOC ;NO
HRRZ C,2(C) ; SHOULD BE DECL,,TIME
CAIE A,(C)
ILLOC: SETZM -1(P) ; RET 0 IN B
JRST POPBCJ
; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED
MFUNCTION %STRUC,SUBR,[STRUCTURED?]
ENTRY 1
GETYP A,(AB) ; GET TYPE
PUSHJ P,ISTRUC ; INTERNAL
JRST IFALSE
JRST ITRUTH
; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE
MFUNCTION %LEGAL,SUBR,[LEGAL?]
ENTRY 1
MOVEI B,(AB) ; POINT TO ARG
PUSHJ P,ILEGQ
JRST IFALSE
JRST ITRUTH
ILEGQ: GETYP A,(B)
CAIN A,TILLEG
POPJ P,
PUSHJ P,SAT ; GET STORG TYPE
CAIN A,SFRAME ; FRAME?
PUSHJ P,CHFRAM
CAIE A,SLOCA
CAIN A,SARGS ; ARG TUPLE
PUSHJ P,ICHARG
CAIN A,SLOCID ; ID LOCATIVE
PUSHJ P,ICHLOC
JUMPE B,CPOPJ
JRST CPOPJ1
; COMPILERS CALL
CILEGQ: PUSH TP,A
PUSH TP,B
MOVEI B,-1(TP)
PUSHJ P,ILEGQ
TDZA 0,0
MOVEI 0,1
SUB TP,[2,,2]
JUMPE 0,NO
YES: MOVSI A,TATOM
MOVE B,IMQUOTE T
JRST CPOPJ1
NOM: SUBM M,(P)
NO: MOVSI A,TFALSE
MOVEI B,0
POPJ P,
YESM: SUBM M,(P)
JRST YES
;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS
MFUNCTION BITS,SUBR
ENTRY
JUMPGE AB,TFA ;AT LEAST ONE ARG ?
GETYP A,(AB)
CAIE A,TFIX
JRST WTYP1
SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE
CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE
JRST OUTRNG
MOVEI B,0
CAML AB,[-2,,0] ;ONLY ONE ARG ?
JRST ONEF ;YES
CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?
JRST TMA ;YES, LOSE
GETYP A,(AB)+2
CAIE A,TFIX
JRST WTYP2
SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE
JRST OUTRNG
ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD
CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE
JRST OUTRNG
LSH B,6
ONEF: ADD B,(AB)+1
LSH B,30 ;FORM BYTE POINTER'S LEFT HALF
MOVSI A,TBITS
JRST FINIS
MFUNCTION GETBITS,SUBR
ENTRY 2
GETYP A,(AB)
PUSHJ P,SAT
CAIN A,SSTORE
JRST .+3
CAIE A,S1WORD
JRST WTYP1
GETYP A,(AB)+2
CAIE A,TBITS
JRST WTYP2
MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD
HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER
LDB B,A
MOVSI A,TWORD ; ALWAYS RETURN WORD____
JRST FINIS
MFUNCTION PUTBITS,SUBR
ENTRY
CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?
JRST TFA ;NO, LOSE
GETYP A,(AB)
PUSHJ P,SAT
CAIE A,S1WORD
JRST WTYP1
GETYP A,(AB)+2
CAIE A,TBITS
JRST WTYP2
MOVEI B,0 ;EMPTY THIRD ARG DEFAULT
CAML AB,[-4,,0] ;ONLY TWO ARGS ?
JRST TWOF
CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?
JRST TMA ;YES, LOSE
GETYP A,(AB)+4
PUSHJ P,SAT
CAIE A,S1WORD
JRST WTYP3
MOVE B,(AB)+5
TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD
HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER
DPB B,A
MOVE B,(AB)+1
MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S
JRST FINIS
; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
MFUNCTION LNTHQ,SUBR,[LENGTH?]
ENTRY 2
GETYP A,(AB)2
CAIE A,TFIX
JRST WTYP2
PUSH P,(AB)3
JRST LNTHER
MFUNCTION LENGTH,SUBR
ENTRY 1
PUSH P,[377777777777]
LNTHER: MOVE B,AB ;POINT TO ARGS
PUSHJ P,PTYPE ;GET ITS PRIM TYPE
MOVE B,1(AB)
MOVE C,(AB)
PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE
JRST LFINIS ;OTHERWISE USE 0
PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL],[PBYTE,LNCHAR]]
LNLST: SKIPN C,B ; EMPTY?
JRST LNLST2 ; YUP, LEAVE
MOVEI B,1 ; INIT COUNTER
MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE
MOVE PVP,PVSTOR+1
HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER
LNLST1: INTGO ;IN CASE CIRCULAR LIST
CAMLE B,(P)-1
JRST LNLST2
HRRZ C,(C) ;STEP
JUMPE C,.+2 ;DONE, RETRUN LENGTH
AOJA B,LNLST1 ;COUNT AND GO
LNLST2: MOVE PVP,PVSTOR+1
SETZM CSTO(PVP)
POPJ P,
LFINIS: POP P,C
CAMLE B,C
JRST IFALSE
MOVSI A,TFIX ;LENGTH IS AN INTEGER
JRST FINIS
LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2
LNUVEC: HLRES B ;GET LENGTH
MOVMS B ;MAKE POS
POPJ P,
LNCHAR: HRRZ B,C ; GET COUNT
POPJ P,
LNTMPL: GETYP A,(B) ; GET REAL SAT
SUBI A,NUMSAT+1
HRLS A ; READY TO HIT TABLE
ADD A,TD.LNT+1
JUMPGE A,BADTPL
MOVE C,B ; DATUM TO C
XCT (A) ; GET LENGTH
HLRZS C ; REST COUNTER
SUBI B,(C) ; FLUSH IT OFF
MOVEI B,(B) ; IN CASE FUNNY STUFF
MOVSI A,TFIX
POPJ P,
; COMPILERS ENTRIES
CILNT: SUBM M,(P)
PUSH P,[377777,,-1]
MOVE C,A
GETYP A,A
PUSHJ P,CPTYPE ; GET PRIMTYPE
JUMPE A,CILN1
PUSHJ P,@LENTBL(A) ; DISPATCH
MOVSI A,TFIX
CILN2: SUB P,[1,,1]
MPOPJ: SUBM M,(P)
POPJ P,
CILN1: PUSH TP,C
PUSH TP,B
MCALL 1,LENGTH
JRST CILN2
CILNQ: SUBM M,(P)
PUSH P,C
MOVE C,A
GETYP A,A
PUSHJ P,CPTYPE
JUMPE A,CILNQ1
PUSHJ P,@LENTBL(A)
POP P,C
SUBM M,(P)
MOVSI A,TFIX
CAMG B,C
JRST CPOPJ1
MOVSI A,TFALSE
MOVEI B,0
POPJ P,
CILNQ1: PUSH TP,C
PUSH TP,B
PUSH TP,$TFIX
PUSH TP,(P)
MCALL 2,LENGTH?
SUBM M,(P)
GETYP 0,A
CAIE 0,TFALSE
AOS (P)
POPJ P,
MFUNCTION BYTSIZ,SUBR,[BYTE-SIZE]
ENTRY 1
GETYP A,(AB)
PUSHJ P,SAT
CAIE A,SBYTE
JRST WTYP1
LDB B,[300600,,1(AB)]
MOVSI A,TFIX
JRST FINIS
IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG
MOVE B,1(AB)
JRST FINIS
IMFUNCTION QUOTE,FSUBR
ENTRY 1
GETYP A,(AB)
CAIE A,TLIST ;ARG MUST BE A LIST
JRST WTYP1
SKIPN B,1(AB) ;SHOULD HAVE A BODY
JRST TFA
HLLZ A,(B) ; GET IT
MOVE B,1(B)
JSP E,CHKAB
JRST FINIS
MFUNCTION NEQ,SUBR,[N==?]
MOVEI D,1
JRST EQR
MFUNCTION EQ,SUBR,[==?]
MOVEI D,0
EQR: ENTRY 2
GETYP A,(AB) ;GET 1ST TYPE
GETYP C,2(AB) ;AND 2D TYPE
MOVE B,1(AB)
CAIN A,(C) ;CHECK IT
CAME B,3(AB)
JRST @TABLE2(D)
JRST @TABLE1(D)
ITRUTH: MOVSI A,TATOM ;RETURN TRUTH
MOVE B,IMQUOTE T
JRST FINIS
IFALSE: MOVSI A,TFALSE ;RETURN FALSE
MOVEI B,0
JRST FINIS
TABLE1: ITRUTH
TABLE2: IFALSE
ITRUTH
MFUNCTION EMPTY,SUBR,EMPTY?
ENTRY 1
MOVE B,AB
PUSHJ P,PTYPE ;GET PRIMITIVE TYPE
MOVEI A,(A)
JUMPE A,WTYP1
SKIPN B,1(AB) ;GET THE ARG
JRST ITRUTH
CAIN A,PTMPLT ; TEMPLATE?
JRST EMPTPL
CAIE A,P2WORD ;A LIST?
JRST EMPT1 ;NO VECTOR OR CHSTR
JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST
JRST IFALSE
EMPT1: CAIN A,PBYTE
JRST .+3
CAIE A,PCHSTR ;CHAR STRING?
JRST EMPT2 ;NO, VECTOR
HRRZ B,(AB) ; GET COUNT
JUMPE B,ITRUTH ;0 STRING WINS
JRST IFALSE
EMPT2: JUMPGE B,ITRUTH
JRST IFALSE
EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH
JUMPE B,ITRUTH
JRST IFALSE
; COMPILER'S ENTRY TO EMPTY
CEMPTY: PUSH P,A
GETYP A,A
PUSHJ P,CPTYPE
POP P,0
JUMPE A,CEMPT2
JUMPE B,YES ; ALWAYS EMPTY
CAIN A,PTMPLT
JRST CEMPTP
CAIN A,P2WORD
JRST NO
CAIN A,PCHSTR
JRST .+3
JUMPGE B,YES
JRST NO
TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD
JRST NO
JRST YES
CEMPTP: PUSHJ P,LNTMPL
JUMPE B,YES
JRST NO
CEMPT2: PUSH TP,0
PUSH TP,B
MCALL 1,EMPTY?
JUMPE B,NO
JRST YES
MFUNCTION NEQUAL,SUBR,[N=?]
PUSH P,[1]
JRST EQUALR
MFUNCTION EQUAL,SUBR,[=?]
PUSH P,[0]
EQUALR: ENTRY 2
MOVE C,AB ;SET UP TO CALL INTERNAL
MOVE D,AB
ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND
PUSHJ P,IEQUAL ;CALL INTERNAL
JRST EQFALS ;NO SKIP MEANS LOSE
JRST EQTRUE
EQFALS: POP P,C
JRST @TABLE2(C)
EQTRUE: POP P,C
JRST @TABLE1(C)
; COMPILER'S ENTRY TO =? AND N=?
CINEQU: PUSH P,[0]
JRST .+2
CIEQUA: PUSH P,[1]
PUSH TP,A
PUSH TP,B
PUSH TP,C
PUSH TP,D
MOVEI C,-3(TP)
MOVEI D,-1(TP)
SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE
PUSHJ P,IEQUAL
JRST NOE
POP P,C
SUB TP,[4,,4] ; FLUSH TEMPS
JRST @CTAB1(C)
NOE: POP P,C
SUB TP,[4,,4]
JRST @CTAB2(C)
CTAB1: SETZ NOM
CTAB2: SETZ YESM
SETZ NOM
; INTERNAL EQUAL SUBROUTINE
IEQUAL: MOVE B,C ;NOW CHECK THE ARGS
PUSHJ P,PTYPE
MOVE B,D
PUSHJ P,PTYPE
MOVE F,0 ; SAVE SAT FOR OFFSET HACK
GETYP 0,(C) ;NOW CHECK FOR EQ
GETYP B,(D)
MOVE E,1(C)
CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER
CAME E,1(D) ;DEFINITE WINNER, SKIP
JRST IEQ1
CPOPJ1: AOS (P) ;EQ, SKIP RETURN
POPJ P,
IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH
CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS
CAIN F,SOFFS
JRST EQOFFS
JRST @EQTBL(A) ;DISPATCH
PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL],[PBYTE,EQCHST]]
EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK
EQLST1: INTGO ;IN CASE OF CIRCULAR
HRRZ C,-2(TP) ;GET FIRST
HRRZ D,(TP) ;AND 2D
CAIN C,(D) ;EQUAL?
JRST EQLST2 ;YES, LEAVE
JUMPE C,EQLST3 ;NIL LOSES
JUMPE D,EQLST3
GETYP 0,(C) ;CHECK DEFERMENT
CAIN 0,TDEFER
HRRZ C,1(C) ;PICK UP POINTED TO CROCK
GETYP 0,(D)
CAIN 0,TDEFER
HRRZ D,1(D) ;POINT TO REAL GOODIE
PUSHJ P,IEQUAL ;CHECK THE CARS
JRST EQLST3 ;LOSE
HRRZ C,@-2(TP) ;CDR THE LISTS
HRRZ D,@(TP)
HRRZM C,-2(TP) ;AND STORE
HRRZM D,(TP)
JRST EQLST1
EQLST2: AOS (P) ;SKIP RETRUN
EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT
POPJ P,
; HERE FOR HACKING OFFSETS
EQOFFS: HRRZ A,1(C)
HRRZ B,1(D) ; GET NUMBERS
CAIE A,(B) ; POSSIBLE WINNER IF SKIP
POPJ P,
PUSH TP,$TLIST
HLRZ A,1(C)
PUSH TP,A
PUSH TP,$TLIST
HLRZ A,1(D)
PUSH TP,A
JRST EQLST1 ; SEE IF THE TWO LISTS ARE EQUAL
; HERE FOR HACKING TEMPLATE STRUCTURES
EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES
PUSHJ P,PUSHCD
MOVE C,1(C) ; CHECK REAL SATS
GETYP C,(C)
MOVE D,1(D)
GETYP 0,(D)
CAIE 0,(C) ; SKIP IF WINNERS
JRST EQTMP4
PUSH P,0 ; SAVE MAGIC OFFSET
MOVE B,-2(TP)
PUSHJ P,TM.LN1 ; RET LENGTH IN B
MOVEI B,(B) ; FLUSH FUNNY
HLRZ C,-2(TP)
SUBI B,(C)
PUSH P,B
MOVE C,(TP) ; POINTER TO OTHER GUY
ADD A,TD.LNT+1
XCT (A) ; OTHER LENGTH TO B
HLRZ 0,-2(TP) ; REST OFFSETTER
SUBI 0,1
PUSH P,0
MOVEI B,(B)
HLRZ C,(TP)
SUBI B,(C)
HRRZS -4(TP) ; UNDO RESTING (ACCOUNTED FOR BY STARTING
; AT LATER ELEMENT)
HRRZS -6(TP)
CAME B,-1(P)
JRST EQTMP1
EQTMP2: AOS C,(P)
SOSGE -1(P)
JRST EQTMP3 ; WIN!!
MOVE B,-6(TP) ; POINTER
MOVE 0,-2(P) ; GET MAGIC OFFSET
PUSHJ P,TMPLNT ; GET AN ELEMENT
MOVEM A,-3(TP)
MOVEM B,-2(TP)
MOVE C,(P)
MOVE B,-4(TP) ; OTHER GUY
MOVE 0,-2(P)
PUSHJ P,TMPLNT
MOVEM A,-1(TP)
MOVEM B,(TP)
MOVEI C,-3(TP)
MOVEI D,-1(TP)
PUSHJ P,IEQUAL ; RECURSE
JRST EQTMP1 ; LOSER
JRST EQTMP2 ; WINNER
EQTMP3: AOS -3(P) ; WIN RETURN
EQTMP1: SUB P,[3,,3] ; FLUSH JUNK
EQTMP4: SUB TP,[10,,10]
POPJ P,
EQVEC: HLRE A,1(C) ;GET LENGTHS
HLRZ B,1(D)
CAIE B,(A) ;SKIP IF EQUAL LENGTHS
POPJ P, ;LOSE
JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN
PUSHJ P,PUSHCD ;SAVE ARGS
EQVEC1: INTGO ;IN CASE LONG VECTOR
MOVE C,(TP)
MOVE D,-2(TP) ;ARGS TO C AND D
PUSHJ P,IEQUAL
JRST EQLST3
MOVE C,[2,,2] ;GET BUMPER
ADDM C,(TP)
ADDB C,-2(TP) ;BUMP BOTH POINTERS
JUMPL C,EQVEC1
JRST EQLST2
EQUVEC: HLRE A,1(C) ;GET LENGTHS
HLRZ B,1(D)
CAIE B,(A) ;SKIP IF EQUAL
POPJ P,
HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN
SUB B,A ;B POINTS TO DOPE WORD
GETYP 0,(B) ;GET UNIFORM TYPE
HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD
SUB B,A
GETYP B,(B) ;OTHER UNIFORM TYPE
CAIE 0,(B) ;TYPES THE SAME?
POPJ P, ;NO, LOSE
JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON
HRLZI B,(B) ;TYPE TO LH
PUSH P,B ;AND SAVED
PUSHJ P,PUSHCD ;SAVE ARGS
EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO
PUSH TP,(P)
MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS
PUSH TP,(A) ; PUSH ELEMENT
MOVEI D,1(TP) ;POINT TO 2D ARG
PUSH TP,(P)
MOVE A,-3(TP) ;AND PUSH ITS POINTER
PUSH TP,(A)
PUSHJ P,IEQUAL
JRST UNEQUV
SUB TP,[4,,4] ;POP TP
MOVE A,[1,,1]
ADDM A,(TP) ;BUMP POINTERS
ADDB A,-2(TP)
JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF
SUB P,[1,,1] ;POP OFF TYPE
JRST EQLST2
UNEQUV: SUB P,[1,,1]
SUB TP,[10,,10]
POPJ P,
EQCHST: HRRZ B,(C) ; GET LENGTHS
HRRZ A,(D)
CAIE A,(B) ;SAME
JRST EQCHS3 ;NO, LOSE
LDB 0,[300600,,1(C)]
LDB E,[300600,,1(D)]
CAIE 0,(E)
JRST EQCHS3
MOVE C,1(C)
MOVE D,1(D)
JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS
EQCHS2:
ILDB 0,C ;GET NEXT CHARS
ILDB E,D
CAME 0,E ; SKIP IF STILL WINNING
JRST EQCHS3 ; NOT =
SOJG A,EQCHS2
EQCHS4: AOS (P)
EQCHS3: POPJ P,
PUSHCD: PUSH TP,(C)
PUSH TP,1(C)
PUSH TP,(D)
PUSH TP,1(D)
POPJ P,
; REST/NTH/AT/PUT/GET
; ARG CHECKER
ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED
ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS
ASH 0,-1 ; TO - NO. OF ARGS
AOJG 0,TFA ; 0--TOO FEW
AOJL 0,TMA ; MORE THAT 2-- TOO MANY
MOVEI C,1 ; DEFAULT ARG2
JUMPN 0,ARGS4 ; GET STRUCTURED ARG
ARGS3: GETYP A,2(AB)
CAIN A,TOFFS ; OFFSET?
JRST ARGOFF ; GO DO DECL-CHECK AND SUCH
CAIE A,TFIX ; SHOULD BE FIXED NUMBER
XCT E ; DO ERROR THING
SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE
JRST OUTRNG
ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER
PUSHJ P,PTYPE ; GET PRIM TYPE
MOVEI E,(A) ; DISPATCH CODE TO E
MOVE A,(AB) ; GET ARG 1
MOVE B,1(AB)
POPJ P,
ARGOFF: HLRZ B,3(AB) ; PICK UP DECL POINTER FOR OFFSET
JUMPE B,ARGOF1
MOVE A,(B) ; TYPE WORD
MOVE B,1(B) ; VALUE
MOVE C,(AB)
MOVE D,1(AB)
PUSHJ P,TMATCH ; CHECK THE DECL
JRST WTYP1 ; FIRST ARG WRONG TYPE
ARGOF1: HRRE C,3(AB) ; GET THE FIX
JUMPL C,OUTRNG
JRST ARGS4 ; FINISH
; REST
IMFUNCTION REST,SUBR
ENTRY
PUSHJ P,ARGS1 ; GET AND CHECK ARGS
PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE
MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK
GETYP A,(AB)
PUSHJ P,SAT
CAIN A,SSTORE ; SKIP IF NOT STORAGE
MOVSI C,TSTORA ; USE ITS PRIMTYPE
MOVE A,C
JRST FINIS
PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]
[PCHSTR,SREST],[PTMPLT,TMPRST],[PBYTE,BREST]]
; AT
MFUNCTION AT,SUBR
ENTRY
PUSHJ P,ARGS1
SOJL C,OUTRNG
PUSHJ P,@ATTBL(E)
JRST FINIS
PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
[PCHSTR,STAT],[PTMPLT,TAT],[PBYTE,BTAT]]
; NTH
MFUNCTION NTH,SUBR
ENTRY
PUSHJ P,ARGS1
SOJL C,OUTRNG
PUSHJ P,@NTHTBL(E)
JRST FINIS
PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]
[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
; GET
MFUNCTION GET,SUBR
ENTRY
MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP
PUSHJ P,ARGS5 ; CHECK ARGS
SOJL C,OUTRNG
SKIPN E,IGETBL(E) ; GET DISPATCH ADR
JRST IGETP ; REALLY PUTPROP
JUMPE 0,TMA
PUSHJ P,(E) ; DISPATCH
JRST FINIS
PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]
[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
; GETL
MFUNCTION GETL,SUBR
ENTRY
MOVE E,IIGETL ; ERROR HACK
PUSHJ P,ARGS5
SOJL C,OUTRNG ; LOSER
SKIPN E,IGTLTB(E)
JRST IGETLO ; REALLY GETPL
JUMPE 0,TMA
PUSHJ P,(E) ; DISPATCH
JRST FINIS
IIGETL: JRST IGETLO
PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
[PCHSTR,STAT],[PBYTE,BTAT]]
; ARG CHECKER FOR PUT/GET/GETL
ARGS5: HLRE 0,AB ; -# OF ARGS
ASH 0,-1
ADDI 0,2 ; 0 OR -1 WIN
JUMPG 0,TFA
AOJL 0,TMA ; MORE THAN 3
JRST ARGS3 ; GET ARGS
; PUT
MFUNCTION PUT,SUBR
ENTRY
MOVE E,IIPUTP
PUSHJ P,ARGS5 ; GET ARGS
SKIPN E,IPUTBL(E)
JRST IPUTP
CAML AB,[-5,,] ; SKIP IF GOOD ARRGS
JRST TFA
SOJL C,OUTRNG
PUSH TP,4(AB)
PUSH TP,5(AB)
PUSHJ P,(E)
MOVE A,(AB) ; RET STRUCTURE
MOVE B,1(AB)
JRST FINIS
PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]
[PCHSTR,SPUT],[PTMPLT,TMPPUT],[PBYTE,BPUT]]
; IN
MFUNCTION IN,SUBR
ENTRY 1
MOVEI B,(AB) ; POINT TO ARG
PUSHJ P,PTYPE
MOVS E,A ; REAL DISPATCH TO E
MOVE B,1(AB)
MOVE A,(AB)
GETYP C,A ; IN CASE NEEDED
PUSHJ P,@INTBL(E)
JRST FINIS
PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]
[PCHSTR,SIN],[PTMPLT,TIN],[PBYTE,BINN]]
OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE
JRST OTHIN1 ; MAYBE LOCD
HLLZ 0,VAL(B)
PUSHJ P,RMONCH
MOVE A,VAL(B)
MOVE B,VAL+1(B)
POPJ P,
OTHIN1: CAIN C,TLOCD
JRST VIN
JRST WTYP1
; SETLOC
MFUNCTION SETLOC,SUBR
ENTRY 2
MOVEI B,(AB) ; POINT TO ARG
PUSHJ P,PTYPE ; DO TYPE
MOVS E,A ; REAL TYPE
MOVE B,1(AB)
MOVE C,2(AB) ; PASS ARG
MOVE D,3(AB)
MOVE A,(AB) ; IN CASE
GETYP 0,A
PUSHJ P,@SETTBL(E)
MOVE A,2(AB)
MOVE B,3(AB)
JRST FINIS
PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]
[PCHSTR,SSTUF],[PTMPLT,TSTUF],[PBYTE,BSTUF]]
OTHSET: CAIE 0,TLOCN ; ASSOC?
JRST OTHSE1
HLLZ 0,VAL(B) ; GET MONITORS
PUSHJ P,MONCH
MOVEM C,VAL(B)
MOVEM D,VAL+1(B)
POPJ P,
OTHSE1: CAIE 0,TLOCD
JRST WTYP1
JRST VSTUF
; LREST -- REST A LIST IN B BY AMOUNT IN C
LREST: MOVSI A,TLIST
JUMPE C,CPOPJ
MOVE PVP,PVSTOR+1
MOVEM A,BSTO(PVP)
LREST2: INTGO ;CHECK INTERRUPTS
JUMPE B,OUTRNG ; CANT CDR NIL
HRRZ B,(B) ;CDR THE LIST
SOJG C,LREST2 ;COUNT DOWN
MOVE PVP,PVSTOR+1
SETZM BSTO(PVP) ;RESET BSTO
POPJ P,
; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK
VREST: SKIPA A,$TVEC ; FINAL TYPE
AREST: HRLI A,TARGS
ASH C,1 ; TIMES 2
JRST UREST1
; UREST -- REST A UVECTOR
STORST: SKIPA A,$TSTORA
UREST: MOVSI A,TUVEC
UREST1: JUMPE C,CPOPJ
HRLI C,(C)
JUMPL C,OUTRNG
ADD B,C ; REST IT
CAILE B,-1 ; OUT OF RANGE ?
JRST OUTRNG
POPJ P,
; SREST -- REST A STRING
BREST: SKIPA D,[TBYTE]
SREST: MOVEI D,TCHSTR
PUSH P,D
JUMPE C,SREST1
PUSH P,A ; SAVE TYPE WORD
PUSH P,C ; SAVE AMOUNT
MOVEI D,(A) ; GET LENGTH
CAILE C,(D) ; SKIP IF OK
JRST OUTRNG
LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER
LDB A,[300600,,B] ;SIZE FIELD
PUSH P,A ;SAVE SIZE
IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD
MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD
IDIVI 0,(A) ;BYTES PER WORD IN 0
MOVE E,0 ;COPY OF BYTES PER WORD TO E
SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD
ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY
IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST
ADDI C,(B) ;POINTO WORD WITH C
POP P,A ;RESTORE BITS PER BYTE
JUMPN D,.+3 ; JUMP IF NOT WD BOUNDARY
MOVEI D,(E) ; USE FULL AMOUNT
SUBI C,1 ; POINT TO PREV WORD
IMULI A,(D) ;A/ BITS USED IN LAST WORD
MOVEI 0,36.
SUBI 0,(A) ;0 HAS NEW POSITION FIELD
DPB 0,[360600,,B] ;INTO BYTE POINTER
HRRI B,(C) ;POINT TO RIGHT WORD
POP P,C ; RESTORE AMOUNT
POP P,A
SUBI A,(C) ; NEW LENGTH
SREST1: POP P,0
HRL A,0
POPJ P,
; TMPRST -- REST A TEMPLATE DATA STRUCTURE
TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.
MOVSI D,(D)
HLL C,D
MOVE B,C ; RET IN B
MOVSI A,TTMPLT
POPJ P,
; LAT -- GET A LOCATIVE TO A LIST
LAT: PUSHJ P,LREST ; GET POINTER
JUMPE B,OUTRNG ; YOU LOSE!
MOVSI A,TLOCL ; NEW TYPE
POPJ P,
; UAT -- GET A LOCATIVE TO A UVECTOR
UAT: PUSHJ P,UREST
MOVSI A,TLOCU
JRST POPJL
; VAT -- GET A LOCATIVE TO A VECTOR
VAT: PUSHJ P,VREST ; REST IT AND TYPE IT
MOVSI A,TLOCV
JRST POPJL
; AAT -- GET A LOCATIVE TO AN ARGS BLOCK
AAT: PUSHJ P,AREST
HRLI A,TLOCA
POPJL: JUMPGE B,OUTRNG ; LOST
POPJ P,
; STAT -- LOCATIVE TO A STRING
STAT: PUSHJ P,SREST
TRNN A,-1 ; SKIP IF ANY LEFT
JRST OUTRNG
HRLI A,TLOCS ; LOCATIVE
POPJ P,
; BTAT -- LOCATIVE TO A BYTE-STRING
BTAT: PUSHJ P,BREST
TRNN A,-1 ; SKIP IF ANY LEFT
JRST OUTRNG
HRLI A,TLOCB ; LOCATIVE
POPJ P,
; TAT -- LOCATIVE TO A TEMPLATE
TAT: PUSHJ P,TMPRST
PUSH TP,A
PUSH TP,B
GETYP A,(B) ; GET REAL SAT
SUBI A,NUMSAT+1
HRLS A ; READY TO HIT TABLE
ADD A,TD.LNT+1
JUMPGE A,BADTPL
MOVE C,B ; DATUM TO C
XCT (A) ; GET LENGTH
HLRZS C ; REST COUNTER
SUBI B,(C) ; FLUSH IT OFF
JUMPE B,OUTRNG
MOVE B,(TP)
SUB TP,[2,,2]
MOVSI A,TLOCT
POPJ P,
; LNTH -- NTH OF LIST
LNTH: PUSHJ P,LAT
LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS
HLLZ A,(B) ; GET GOODIE
MOVE B,1(B)
JSP E,CHKAB ; HACK DEFER
POPJ P,
; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK
ANTH: PUSHJ P,AAT
JRST .+2
VNTH: PUSHJ P,VAT
AIN:
VIN: PUSHJ P,RMONC0
MOVE A,(B)
MOVE B,1(B)
POPJ P,
; UNTH -- NTH OF UVECTOR
UNTH: PUSHJ P,UAT
UIN: HLRE C,B ; FIND DW
SUBM B,C
HLLZ 0,(C) ; GET MONITORS
MOVE D,0
TLZ D,TYPMSK#<-1>
PUSH P,D
PUSHJ P,RMONCH ; CHECK EM
POP P,A
MOVE B,(B) ; AND VALUE
POPJ P,
; BNTH -- NTH A BYTE STRING
BNTH: PUSHJ P,BTAT
BINN: PUSH P,$TFIX
JRST SIN1
; SNTH -- NTH A STRING
SNTH: PUSHJ P,STAT
SIN: PUSH P,$TCHRS
SIN1: PUSH TP,A
PUSH TP,B ; SAVE POINT BYTER
MOVEI C,-1(TP) ; FIND DOPE WORD
PUSHJ P,BYTDOP
HLLZ 0,-1(A) ; GET
POP TP,B
POP TP,A
PUSHJ P,RMONCH
ILDB B,B ; GET CHAR
POP P,A
POPJ P,
; TIN -- IN OF A TEMPLATE
TIN: MOVEI C,0
; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE
TMPLNT: ADDI C,1
PUSHJ P,TM.TOE ; GET POINTER TO INS IN E
ADD A,TD.GET+1 ; POINT TO GETTER
MOVE A,(A) ; GET VECTOR OF INS
ADDI E,-1(A) ; POINT TO INS
SUBI D,1
XCT (E) ; DO IT
JFCL ; SKIP IF AN ANY CASE
POPJ P, ; RETURN
; LPUT -- PUT ON A LIST
LPUT: PUSHJ P,LAT ; POSITION
POP TP,D
POP TP,C
; LSTUF -- HERE TO STUFF A LIST ELEMENT
LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS
GETYP A,C ; ISOLATE TYPE
PUSHJ P,NWORDT ; NEED TO DEFER?
SOJN A,DEFSTU
HLLM C,(B)
MOVEM D,1(B) ; AND VAL
POPJ P,
DEFRCY: MOVE E,1(B) ; RECYCLE THIS HANDY DEFER
MOVEM C,(E)
MOVEM D,1(E)
POPJ P,
DEFSTU: GETYP A,(B)
CAIN A,TDEFER
JRST DEFRCY
PUSH TP,$TLIST
PUSH TP,B
PUSH TP,C
PUSH TP,D
PUSHJ P,CELL2 ; GET WORDS
POP TP,1(B)
POP TP,(B)
MOVE E,(TP)
SUB TP,[2,,2]
MOVEM B,1(E)
HLLZ 0,(E) ; GET OLD MONITORS
TLZ 0,TYPMSK ; KILL TYPES
TLO 0,TDEFER ; MAKE DEFERRED
HLLM 0,(E)
POPJ P,
; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
APUT: PUSHJ P,AAT
JRST .+2
VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
POP TP,D ; GET GOODIE BACK
POP TP,C
; AVSTUF -- CLOBBER ARGS AND VECTORS
ASTUF:
VSTUF: PUSHJ P,MONCH0
MOVEM C,(B)
MOVEM D,1(B)
POPJ P,
; UPUT -- CLOBBER A UVECTOR
UPUT: PUSHJ P,UAT ; GET IT RESTED
POP TP,D
POP TP,C
; USTUF -- HERE TO CLOBBER A UVECTOR
USTUF: HLRE E,B
SUBM B,E ; C POINTS TO DOPE
GETYP A,(E) ; GET UTYPE
GETYP 0,C
CAIE 0,(A) ; CHECK SAMENESS
JRST WRNGUT
HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
MOVSI A,TLOCU ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
PUSHJ P,MONCH
MOVEM D,(B) ; SMASH
POPJ P,
; BPUT -- HERE TO PUT A BYTE-STRING
BPUT: PUSHJ P,BTAT
POP TP,D
POP TP,C
BSTUF: MOVEI E,TFIX
JRST SSTUF1
; SPUT -- HERE TO PUT A STRING
SPUT: PUSHJ P,STAT ; REST IT
POP TP,D
POP TP,C
; SSTUF -- STUFF A STRING
SSTUF: MOVEI E,TCHRS
SSTUF1: GETYP 0,C ; BETTER BE CHAR
CAIE 0,(E)
JRST WTYP3
PUSH P,C
PUSH TP,A
PUSH TP,B
MOVEI C,-1(TP) ; FIND D.W.
PUSHJ P,BYTDOP
SKIPGE (A)-1 ; SKIP IF NOT REALLY ATOM
JRST PNMNG
HLLZ 0,(A)-1 ; GET MONITORS
POP TP,B
POP TP,A
POP P,C
PUSHJ P,MONCH
IDPB D,B ; STASH
POPJ P,
PNMNG: POP TP,B
POP TP,A
PUSH TP,$TATOM
PUSH TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
HRLI A,TCHSTR
PUSH TP,A
PUSH TP,B
MOVEI A,2
JRST CALER
; TSTUF -- SETLOC A TEMPLATE
TSTUF: PUSH TP,C
PUSH TP,D
MOVEI C,0
; PUTTMP -- TEMPLATE PUTTER
TMPPUT: ADDI C,1
PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
ADD A,TD.PUT+1 ; POINT TO INS
MOVE A,(A) ; GET VECTOR OF INS
ADDI E,-1(A)
POP TP,B ; NEW VAL TO A AND B
POP TP,A
SUBI D,1
XCT (E) ; DO IT
JRST BADPUT
POPJ P,
TM.LN1: SUBI 0,NUMSAT+1
HRRZ A,0 ; RET FIXED OFFSET
HRLS 0
ADD 0,TD.LNT+1 ; USE LENGTHERS FOR TEST
JUMPGE 0,BADTPL
PUSH P,C
MOVE C,B
HRRZS 0 ; POINT TO TABLE ENTRY
PUSH P,A
XCT @0 ; DO IT
POP P,A
POP P,C
POPJ P,
TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
TLNN B,-1 ; SKIP IF REST HAIR EXISTS
POPJ P, ; NO, WIN
PUSH P,A ; SAVE OFFSET
HRLS A ; A IS REL OFFSET TO INS TABLE
ADD A,TD.GET+1 ; GET ONEOF THE TABLES
MOVE A,(A) ; TABLE POINTER TO A
MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
ADD 0,A
JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
HLRZ E,B ; BASIC LENGTH TO E
HLRE 0,A ; LENGTH OF TEMPLATE TO 0
ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
MOVNS 0
SUBM D,E ; E ==> # PAST BASIC WANTED
EXCH 0,E
IDIVI 0,(E) ; A ==> REL REST GUY WANTED
HLRZ E,B
ADDI E,1(A)
CPOPJA: POP P,A
POPJ P,
; TM.TOE -- GET RIGHT TEMPLATE # IN E
; C/ OBJECT #, B/ OBJECT POINTER
TM.TOE: GETYP 0,(B) ; GET REAL SAT
MOVEI D,(C) ; OBJ # TO D
HLRZ C,B ; REST COUNT
ADDI D,(C) ; FUDGE FOR REST COUNTER
MOVE C,B ; POINTER TO C
PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
CAILE D,(B) ; CHECK RANGE
JRST OUTRNG ; LOSER, QUIT
JRST TM.TBL ; GO COMPUTE TABLE OFFSET
; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
; FIXES (P)
CPTYEE: MOVE E,A
GETYP A,A
PUSHJ P,CPTYPE
JUMPE A,WTYPUN
SUBM M,-1(P)
EXCH E,A
POPJ P,
; COMPILER CALLS TO MANY OF THESE GUYS
CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
HRRES C ; CLEAR LH, IN CASE IT'S AN OFFSET
JUMPL C,OUTRNG
CAIN 0,SSTORE
JRST CIRST1
PUSHJ P,@RESTBL(E)
JRST MPOPJ
CIRST1: PUSHJ P,STORST
JRST MPOPJ
CINTH: PUSHJ P,CPTYEE
HRRES C ; CLEAR LH
SOJL C,OUTRNG ; CHECK BOUNDS
PUSHJ P,@NTHTBL(E)
JRST MPOPJ
CIAT: PUSHJ P,CPTYEE
SOJL C,OUTRNG
PUSHJ P,@ATTBL(E)
JRST MPOPJ
CSETLO: PUSHJ P,CTYLOC
MOVSS E ; REAL DISPATCH
GETYP 0,A ; INCASE LOCAS OR LOCD
PUSH TP,C
PUSH TP,D
PUSHJ P,@SETTBL(E)
POP TP,B
POP TP,A
JRST MPOPJ
CIN: PUSHJ P,CTYLOC
MOVSS E ; REAL DISPATCH
GETYP C,A
PUSHJ P,@INTBL(E)
JRST MPOPJ
CTYLOC: MOVE E,A
GETYP A,A
PUSHJ P,CPTYPE
SUBM M,-1(P)
EXCH A,E
POPJ P,
; COMPILER'S PUT,GET AND GETL
CIGET: PUSH P,[0]
JRST .+2
CIGETL: PUSH P,[1]
MOVE E,A
GETYP A,A
PUSHJ P,CPTYPE
EXCH A,E
JUMPE E,CIGET1 ; REAL GET, NOT NTH
GETYP 0,C ; INDIC FIX?
CAIE 0,TFIX
CAIN 0,TOFFS
JRST .+2
JRST CIGET1
POP P,E ; GET FLAG
AOS (P) ; ALWAYS SKIP
MOVE C,D ; # TO AN AC
JRST @.+1(E)
SETZ CINTH
SETZ CIAT
CIGET1: POP P,E ; GET FLAG
JRST @GETTR(E) ; DO A REAL GET
GETTR: SETZ CIGTPR
SETZ CIGETP
CIPUT: SUBM M,(P)
MOVE E,A
GETYP A,A
PUSHJ P,CPTYPE
EXCH A,E
PUSH TP,-1(TP) ; PAIN AND SUFFERING
PUSH TP,-1(TP)
MOVEM A,-3(TP)
MOVEM B,-2(TP)
JUMPE E,CIPUT1
GETYP 0,C
CAIE 0,TFIX ; YES DO STRUCT
CAIN 0,TOFFS
JRST .+2
JRST CIPUT1
MOVE C,D
HRRES C
SOJL C,OUTRNG ; CHECK BOUNDS
PUSHJ P,@IPUTBL(E)
PMPOPJ: POP TP,B
POP TP,A
JRST MPOPJ
CIPUT1: PUSHJ P,IPUT
JRST PMPOPJ
; SMON -- SET MONITOR BITS
; B/ <POINTER TO LOCATIVE>
; D/ <IORM> OR <ANDCAM>
; E/ BITS
SMON: GETYP A,(B)
PUSHJ P,PTYPE ; TO PRIM TYPE
HLRZS A
SKIPE A,SMONTB(A) ; DISPATCH?
JRST (A)
; COULD STILL BE LOCN OR LOCD
GETYP A,(B) ; TYPE BACK
CAIE A,TLOCN
JRST SMON2 ; COULD BE LOCD
MOVE C,1(B) ; POINT
HRRI D,VAL(C) ; MAKE INST POINT
JRST SMON3
SMON2: CAIE A,TLOCD
JRST WRONGT
; SET LIST/TUPLE/ID LOCATIVE
SMON4: HRR D,1(B) ; POINT TO TYPE WORD
SMON3: XCT D
POPJ P,
; SET UVEC LOC
SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
HLRE 0,1(B)
SUB C,0 ; POINT TO DOPE
HRRI D,(C) ; POINT IN INST
JRST SMON3
; SET CHSTR LOC
SMON6: MOVEI C,(B) ; FOR BYTDOP
PUSHJ P,BYTDOP ; POINT TO DOPE
HRRI D,(A)-1
JRST SMON3
PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
[PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
; COMPILER'S MONAD?
CIMON: PUSH P,A
GETYP A,A
PUSHJ P,CPTYPE
JUMPE A,CIMON1
POP P,A
JRST CEMPTY
CIMON1: POP P,A
JRST YES
; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
MFUNCTION MONAD,SUBR,MONAD?
ENTRY 1
MOVE B,AB ; CHECK PRIM TYPE
PUSHJ P,PTYPE
JUMPE A,ITRUTH ;RETURN ARGUMENT
SKIPE B,1(AB)
JRST @MONTBL(A) ;DISPATCH ON PTYPE
JRST ITRUTH
PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
[PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
JRST IFALSE
CHMON: HRRZ B,(AB)
JUMPE B,ITRUTH
JRST IFALSE
TMPMON: PUSHJ P,LNTMPL
JUMPE B,ITRUTH
JRST IFALSE
CISTRU: GETYP A,A ; COMPILER CALL
PUSHJ P,ISTRUC
JRST NO
JRST YES
ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
SKIPE A,PRMTYP(A)
AOS (P) ; SKIP IF WINS
POPJ P,
; SUBR TO CHECK FOR LOCATIVE
MFUNCTION %LOCA,SUBR,[LOCATIVE?]
ENTRY 1
GETYP A,(AB)
PUSHJ P,LOCQQ
JRST IFALSE
JRST ITRUTH
; SKIPS IF TYPE IN A IS A LOCATIVE
LOCQ: GETYP A,(B) ; GET TYPE
LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
PUSHJ P,SAT
MOVE A,PRMTYP(A)
JUMPE A,LOCQ1
SUB P,[1,,1]
TRNN A,-1
LOCQ2: AOS (P)
POPJ P,
LOCQ1: POP P,A ; RESTORE TYPE
CAIE A,TLOCN
CAIN A,TLOCD
JRST LOCQ2
POPJ P,
; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
MFUNCTION MEMBER,SUBR
MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
JRST MEMB
MFUNCTION MEMQ,SUBR
MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
MEMB: ENTRY 2
MOVE B,AB ;POINT TO FIRST ARG
PUSHJ P,PTYPE ;CHECK PRIM TYPE
ADD B,[2,,2] ;POINT TO 2ND ARG
PUSHJ P,PTYPE
JUMPE A,WTYP2 ;2ND WRONG TYPE
PUSH TP,(AB)
PUSH TP,1(AB)
MOVE C,2(AB) ; FOR TUPLE CASE
SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
PUSHJ P,@MEMTBL(A) ;DISPATCH
JRST IFALSE ;OR REPORT LOSSAGE
JRST FINIS
PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
MOVE PVP,PVSTOR+1
MOVEM 0,BSTO(PVP)
JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
MEMLS1: INTGO ;CHECK INTERRUPTS
MOVEI C,(B) ;COPY POINTER
GETYP D,(C) ;GET TYPE
MOVSI A,(D) ;COPY
CAIE D,TDEFER ;DEFERRED?
JRST MEMLS2
MOVE C,1(C) ;GET DEFERRED DATUM
GETYPF A,(C) ;GET FULL TYPE WORD
MEMLS2: MOVE C,1(C) ;GET DATUM
XCT E ;DO THE COMPARISON
JRST MEMLS3 ;NO MATCH
MOVSI A,TLIST
MEMLS5: AOS (P)
MEMLS6: MOVE PVP,PVSTOR+1
SETZM BSTO(PVP) ;RESET B'S TYPE
POPJ P,
MEMLS3: HRRZ B,(B) ;STEP THROGH
JUMPN B,MEMLS1 ;STILL MORE TO DO
MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
JRST MEMLS6 ;RETURN 0
MEMTUP: HRRZ A,C
TLOA A,TARGS
MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
JUMPGE B,MEMLS4 ;EMPTY VECTOR
MOVE PVP,PVSTOR+1
MOVEM A,BSTO(PVP)
MEMV1: INTGO ;CHECK FOR INTS
GETYPF A,(B) ;GET FULL TYPE
MOVE C,1(B) ;AND DATA
XCT E ;DO COMPARISON INS
JRST MEMV2 ;NOT EQUAL
MOVE PVP,PVSTOR+1
MOVE A,BSTO(PVP)
JRST MEMLS5 ;RETURN WITH POINTER
MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
JUMPL B,MEMV1 ;STILL WINNING
MEMV3: MOVEI B,0
JRST MEMLS4 ;AND RETURN FALSE
MUVEC: JUMPGE B,MEMLS4
GETYP A,-1(TP) ;GET TYPE OF GODIE
HLRE C,B ;LOOK FOR UNIFORM TYPE
SUBM B,C ;DOPE POINTER TO C
GETYP C,(C) ;GET THE TYPE
CAIE A,(C) ;ARE THEY THE SAME?
JRST MEMLS4 ;NO, LOSE
MOVSI A,TUVEC
CAIN 0,SSTORE
MOVSI A,TSTORA
PUSH P,A
MOVE PVP,PVSTOR+1
MOVEM A,BSTO(PVP)
MOVSI A,(C) ;TYPE TO LH
PUSH P,A ; SAVE FOR EACH TEST
MUVEC1: INTGO ;CHECK OUT INTS
MOVE C,(B) ;GET DATUM
MOVE A,(P) ; GET TYPE
XCT E ;COMPARE
AOBJN B,MUVEC1 ;LOOP TO WINNAGE
SUB P,[1,,1]
POP P,A
JUMPGE B,MEMV3 ;LOSE RETURN
MUVEC2: JRST MEMLS5
MEMBYT: MOVEI 0,TFIX
MOVEI D,TBYTE
JRST MEMBY1
MEMCH: MOVEI 0,TCHRS
MOVEI D,TCHSTR
MEMBY1: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
CAIE 0,(A) ;SKIP IF POSSIBLE WINNER
JRST MEMSTR
MOVEI 0,(C)
MOVE D,(TP) ; AND CHAR
MEMCH1: SOJL 0,MEMV3
MOVE E,B
ILDB A,B
CAIE A,(D) ;CHECK IT
SOJA C,MEMCH1
MEMCH2: MOVE B,E
MOVE A,C
JRST MEMLS5
MEMSTR: CAIN A,(D)
CAME E,[PUSHJ P,EQLTST]
JRST MEMV3
LDB A,[300600,,(TP)]
LDB 0,[300600,,B]
CAIE 0,(A)
JRST MEMV3
MOVEI 0,(C) ; GET # OF CHAR INTO 0
ILDB D,(TP)
PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
MOVE E,B
ILDB A,B
CAME A,(P)
SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
PUSH P,B
PUSH P,E
PUSH P,C
PUSH P,0
MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
HRRZ C,-1(TP) ; LENGTH OF 1ARG
MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
ILDB A,B
ILDB D,E
CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
JRST MEMST2
POP P,0
POP P,C
POP P,E
POP P,B
SOJA C,MEMST1
MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
MOVE A,-1(P)
SUB P,[5,,5]
JRST MEMLS5
MEMLSR: SUB P,[5,,5]
JRST MEMV3
MEMLS: SUB P,[1,,1]
JRST MEMV3
; MEMBERSHIP FOR TEMPLATE HACKER
MEMTMP: GETYP 0,(B) ; GET REAL SAT
PUSH P,E
PUSH P,0
PUSH TP,A
PUSH TP,B ; SAVE GOOEIE
PUSHJ P,TM.LN1 ; GET LENGTH
MOVEI B,(B)
HLRZ A,(TP) ; FUDGE FOR REST
SUBI B,(A)
PUSH P,B ; SAVE LENGTH
PUSH P,[-1]
POP TP,B
POP TP,A
MOVE PVP,PVSTOR+1
MOVEM B,BSTO+1(PVP)
MEMTM1: MOVE PVP,PVSTOR+1
SETZM BSTO(PVP)
AOS C,(P)
SOSGE -1(P)
JRST MEMTM2
MOVE 0,-2(P)
PUSHJ P,TMPLNT ; GET ITEM
EXCH C,B ; VALUE TO C, POINTER BACK TO B
MOVE E,-3(P)
MOVSI 0,TTMPLT
MOVE PVP,PVSTOR+1
MOVEM 0,BSTO(PVP)
XCT E
SKIPA
JRST MEMTM3
MOVE PVP,PVSTOR+1
MOVE B,BSTO+1(PVP)
JRST MEMTM1
MEMTM3: MOVE PVP,PVSTOR+1
MOVE B,BSTO+1(PVP)
HRL B,(P) ; DO APPROPRIATE REST
AOS -4(P)
MEMTM2: SUB P,[4,,4]
MOVSI A,TTMPLT
MOVE PVP,PVSTOR+1
SETZM BSTO(PVP)
POPJ P,
EQTST: GETYP A,A
GETYP 0,-1(TP)
CAMN C,(TP) ;CHECK VALUE
CAIE 0,(A) ;AND TYPE
POPJ P,
JRST CPOPJ1
EQLTST: MOVE PVP,PVSTOR+1
PUSH TP,BSTO(PVP)
PUSH TP,B
PUSH TP,A
PUSH TP,C
SETZM BSTO(PVP)
PUSH P,E ;SAVE INS
MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
MOVEI D,-1(TP)
AOS -1(P) ;ASSUME SKIP
PUSHJ P,IEQUAL ;GO INO EQUAL
SOS -1(P) ;UNDO SKIP
SUB TP,[2,,2] ;AND POOP OF CRAP
POP TP,B
MOVE PVP,PVSTOR+1
POP TP,BSTO(PVP)
POP P,E
POPJ P,
; COMPILER MEMQ AND MEMBER
CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
CIMEMQ: MOVE E,[PUSHJ P,EQTST]
SUBM M,(P)
PUSH TP,A
PUSH TP,B
GETYP A,C
PUSHJ P,CPTYPE
JUMPE A,WTYPUN
MOVE B,D ; STRUCT TO B
PUSHJ P,@MEMTBL(A)
TDZA 0,0 ; FLAG NO SKIP
MOVEI 0,1 ; FLAG SKIP
SUB TP,[2,,2]
JUMPE 0,NOM
SOS (P) ; SKIP RETURN
JRST MPOPJ
; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
MFUNCTION TOP,SUBR
ENTRY 1
MOVE B,AB ;CHECK ARG
PUSHJ P,PTYPE
MOVEI E,(A)
MOVE A,(AB)
MOVE B,1(AB)
PUSHJ P,@TOPTBL(E) ;DISPATCH
JRST FINIS
PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
[PTMPLT,BCKTOP],[PBYTE,BTOP]]
BCKTOP: MOVEI B,(B) ; FIX UP POINTER
MOVSI A,TTMPLT
POPJ P,
UVTOP: SKIPA A,$TUVEC
VTOP: MOVSI A,TVEC
CAIN 0,SSTORE
MOVSI A,TSTORA
JUMPE B,CPOPJ
HLRE C,B ;AND -LENGTH
HRRZS B
SUB B,C ;POINT TO DOPE WORD
HLRZ D,1(B) ;TOTAL LENGTH
SUBI B,-2(D) ;POINT TO TOP
MOVNI D,-2(D) ;-LENGTH
HRLI B,(D) ;B NOW POINTS TO TOP
POPJ P,
BTOP: SKIPA E,$TBYTE
CHTOP: MOVSI E,TCHSTR
JUMPE B,CPOPJ
PUSH P,E
PUSH TP,A
PUSH TP,B
LDB 0,[360600,,(TP)] ; POSITION FIELD
LDB E,[300600,,(TP)] ; AND SIZE FILED
IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
MOVEI C,36. ; BITS PER WORD
IDIVI C,(E) ; BYTES PER WORD
PUSH P,C
SUBM C,0 ; UNUSED BYTES I 1ST WORD
ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
MOVEI C,-1(TP) ; GET DOPE WORD
PUSHJ P,BYTDOP
HLRZ C,(A) ; GET LENGTH
SKIPGE -1(A) ; SKIP IF NOT REALLY ATOM
SUBI C,3 ; IF IT IS, 3 LESS WORDS
SUBI A,-1(C) ; START +1
MOVEI B,-1(A) ; SETUP BYTER
SUB A,(TP) ; WORDS DIFFERENT
IMUL A,(P) ; CHARS EXTRA
SUBM 0,A ; FINAL TOTAL TO A
HLL A,-1(P)
MOVE C,(P)
SUB P,[2,,2]
DPB E,[300600,,B]
IMULI E,(C) ; BITS USED IN FULL WORD
MOVEI C,36.
SUBI C,(E) ; WHERE TO POINT IN EMPTY? CASE
DPB C,[360600,,B]
SUB TP,[2,,2]
POPJ P,
ATOP:
GETATO: HLRE C,B ;GET -LENGTH
HRROS B
SUB B,C ;POINT PAST
GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
CAIN 0,TENTRY ;IF ENTRY
JRST EASYTP ;WANT UNEVALUATED ARGS
HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
SUBI B,(C) ;GO TO TOP
TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
HRLI A,TARGS
POPJ P,
; COMPILERS ENTRY TO TOP
CITOP: PUSHJ P,CPTYEE
CAIN E,P2WORD ; LIST?
JRST WTYPL
PUSHJ P,@TOPTBL(E)
JRST MPOPJ
; FUNCTION TO CLOBBER THE CDR OF A LIST
MFUNCTION PUTREST,SUBR,[PUTREST]
ENTRY 2
MOVE B,AB ;COPY ARG POINTER
PUSHJ P,PTYPE ;CHECK IT
CAIE A,P2WORD ;LIST?
JRST WTYP1 ;NO, LOSE
ADD B,[2,,2] ;AND NEXT ONE
PUSHJ P,PTYPE
CAIE A,P2WORD
JRST WTYP2 ;NOT LIST, LOSE
HRRZ B,1(AB) ;GET FIRST
JUMPE B,OUTRNG
MOVE D,3(AB) ;AND 2D LIST
CAIL B,HIBOT
JRST PURERR
HRRM D,(B) ;CLOBBER
MOVE A,(AB) ;RETURN CALLED TYPE
JRST FINIS
; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
MFUNCTION BACK,SUBR
ENTRY
MOVEI C,1 ;ASSUME BACKING UP ONE
JUMPGE AB,TFA ;NO ARGS IS TOO FEW
CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
JRST BACK1 ;ONLY ONE ARG
GETYP A,2(AB) ;GET TYPE
CAIE A,TFIX ;MUST BE FIXED
JRST WTYP2
SKIPGE C,3(AB) ;GET NUMBER
JRST OUTRNG
CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
JRST TMA
BACK1: MOVE B,AB ;SET UP TO FIND TYPE
PUSHJ P,PTYPE ;GET PRIM TYPE
MOVEI E,(A)
MOVE A,(AB)
SKIPN B,1(AB) ;GET DATUM
JRST OUTRNG
PUSHJ P,@BCKTBL(E)
JRST FINIS
PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
[PTMPLT,BCKTMP],[PBYTE,BACKB]]
BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
SKIPA A,$TVEC
BACKU: MOVSI A,TUVEC
CAIN 0,SSTORE
MOVSI A,TSTORA
HRLI C,(C) ;TO BOTH HALVES
SUB B,C ;BACK UP VECTOR POINTER
HLRE C,B ;FIND OUT IF OVERFLOW
SUBM B,C ;DOPE POINTER TO C
HLRZ D,1(C) ;GET LENGTH
SUBI C,-2(D) ;POINT TO TOP
ANDI C,-1
CAILE C,(B) ;SKIP IF A WINNER
JRST OUTRNG ;COMPLAIN
BACKUV: POPJ P,
BCKTMP: MOVSI C,(C)
SUB B,C ; FIX UP POINTER
JUMPL B,OUTRNG
MOVSI A,TTMPLT
POPJ P,
BACKB: SKIPA E,[TBYTE]
BACKC: MOVEI E,TCHSTR
PUSH TP,A
PUSH TP,B
ADDI A,(C) ; NEW LENGTH
HRLI A,(E)
PUSH P,A ; SAVE COUNT
LDB E,[300600,,B] ;BYTE SIZE
MOVEI 0,36. ;BITS PER WORD
IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
SUBI B,(C) ;BACK WORDS UP
JUMPE D,CHBOUN ;CHECK BOUNDS
IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
LDB A,[360600,,B] ;GET POSITION FILED
BACKC2: ADDI A,(E) ;BUMP
CAIGE A,36.
JRST BACKC1 ;O.K.
SUB A,0
SUBI B,1 ;DECREMENT POINTER PART
BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
DPB A,[360600,,B] ;FIX UP POINT BYTER
CHBOUN: MOVEI C,-1(TP)
PUSHJ P,BYTDOP ; FIND DOPE WORD
HLRZ C,(A)
SKIPGE -1(A) ; SKIP IF NOT REALLY AN ATOM
SUBI C,3 ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
SUBI A,-1(C) ; POINT TO TOP
MOVE C,B ; COPY BYTER
IBP C
CAILE A,(C) ; SKIP IF OK
JRST OUTRNG
POP P,A ; RESTORE COUNT
SUB TP,[2,,2]
POPJ P,
BACKA: LSH C,1 ;NUMBER TIMES 2
HRLI C,(C) ;TO BOTH HALVES
SUB B,C ;FIX POINTER
MOVE E,B ;AND SAVE
PUSHJ P,GETATO ;LOOK A T TOP
CAMLE B,E ;COMPARE
JRST OUTRNG
MOVE B,E
POPJ P,
; COMPILER'S BACK
CIBACK: PUSHJ P,CPTYEE
JUMPL C,OUTRNG
CAIN E,P2WORD
JRST WTYPL
PUSHJ P,@BCKTBL(E)
JRST MPOPJ
MFUNCTION STRCOMP,SUBR
ENTRY 2
MOVE A,(AB)
MOVE B,1(AB)
MOVE C,2(AB)
MOVE D,3(AB)
PUSHJ P,ISTRCM
JRST FINIS
ISTRCM: GETYP 0,A
CAIE 0,TCHSTR
JRST ATMCMP ; MAYBE ATOMS
GETYP 0,C
CAIE 0,TCHSTR
JRST WTYP2
MOVEI A,(A) ; ISOLATR LENGHTS
MOVEI C,(C)
STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
SOJL C,1BIG ; 1ST IS BIGGER
ILDB 0,B
ILDB E,D
CAIN 0,(E) ; SKIP IF DIFFERENT
JRST STRCO2
CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
JRST 1BIG
2BIG: MOVNI B,1
JRST RETFIX
CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
SM.CMP: TDZA B,B ; RETURN 0
1BIG: MOVEI B,1
RETFIX: MOVSI A,TFIX
POPJ P,
ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
JRST WTYP1 ; NO, QUIT
GETYP 0,C
CAIE 0,TATOM
JRST WTYP2
CAMN B,D ; SAME ATOM?
JRST SM.CMP
ADD B,[3,,3] ; SKIP VAL CELL ETC.
ADD D,[3,,3]
ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
CAME 0,(D) ; SAME?
JRST ATMCM3 ; NO, GET DIF
AOBJP B,ATMCM2
AOBJN D,ATMCM1 ; MORE TO COMPARE
JRST 1BIG ; 1ST IS BIGGER
ATMCM2: AOBJP D,SM.CMP ; EQUAL
JRST 2BIG
ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
MOVE C,(D)
LSH C,-1
CAMG 0,C
JRST 2BIG
JRST 1BIG
;ERROR COMMENTS FOR SOME PRIMITIVES
OUTRNG: ERRUUO EQUOTE OUT-OF-BOUNDS
WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
IIPUTP: JRST IPUTP
;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
WNA: ERRUUO EQUOTE WRONG-NUMBER-OF-ARGUMENTS
TFA: ERRUUO EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
TMA: ERRUUO EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
WRONGT:
WTYP: ERRUUO EQUOTE ARG-WRONG-TYPE
IWTYP1:
WTYP1: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
IWTYP2:
WTYP2: ERRUUO EQUOTE SECOND-ARG-WRONG-TYPE
BADTPL: ERRUUO EQUOTE BAD-TEMPLATE-DATA
BADPUT: ERRUUO EQUOTE TEMPLATE-TYPE-VIOLATION
WTYP3: ERRUUO EQUOTE THIRD-ARG-WRONG-TYPE
WTYPL: ERRUUO EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
WTYPUN: ERRUUO EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
CALER1: MOVEI A,1
CALER: HRRZ C,FSAV(TB)
PUSH TP,$TATOM
CAIL C,HIBOT
SKIPA C,@-1(C) ; SUBRS AND FSUBRS
MOVE C,3(C) ; FOR RSUBRS
PUSH TP,C
ADDI A,1
ACALL A,ERROR
JRST FINIS
GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
CAIE B,(CAIE A,) ;AS EXPECTED ?
JRST WNA ;NO,
HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
HLRE A,AB ;GET ACTUAL NUMBER OF ARGS
CAMG B,A
JRST TFA
JRST TMA
END
Reference in New Issue View Git Blame Copy Permalink