mirror of
https://github.com/PDP-10/its.git
synced 2026-01-14 23:55:40 +00:00
a81db26a7a
MIDAS and Muddle source get version numbers (as in the 1973 Muddle source); the build files don't.
1091 lines
19 KiB
Plaintext
1091 lines
19 KiB
Plaintext
|
||
TITLE DECLARATION PROCESSOR
|
||
|
||
RELOCA
|
||
|
||
.INSRT MUDDLE >
|
||
|
||
.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT
|
||
.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC
|
||
.GLOBAL CHLOCI,INCONS,SPCCHK,OUTRNG,WTYP1,FLGSET,IGET,PVSTOR,SPSTOR,DSTORE
|
||
.GLOBAL NOATMS,NOSET,NOSETG
|
||
; Subr to allow user to access the DECL checking code
|
||
|
||
MFUNCTION CHECKD,SUBR,[DECL?]
|
||
|
||
ENTRY 2
|
||
|
||
MOVE C,(AB)
|
||
MOVE D,1(AB)
|
||
MOVE A,2(AB)
|
||
MOVE B,3(AB)
|
||
PUSHJ P,TMATCX ; CHECK THEM
|
||
JRST IFALS
|
||
|
||
RETT: MOVSI A,TATOM
|
||
MOVE B,IMQUOTE T
|
||
JRST FINIS
|
||
|
||
RETF:
|
||
IFALS: MOVEI B,0
|
||
MOVSI A,TFALSE
|
||
JRST FINIS
|
||
|
||
; Subr to turn DECL checking on and off.
|
||
|
||
MFUNCTION %DECL,SUBR,[DECL-CHECK]
|
||
|
||
ENTRY
|
||
|
||
HRROI E,IGDECL
|
||
JRST FLGSET
|
||
|
||
; Subr to turn on and off allowing new atoms
|
||
|
||
MFUNCTION %NEWAT,SUBR,[ALLOW-NEW-ATOMS]
|
||
|
||
ENTRY
|
||
|
||
MOVEI E,NOATMS
|
||
JRST FLGSET
|
||
|
||
; Subr to turn on and off allowing new GVALS
|
||
|
||
MFUNCTION %NEWGV,SUBR,[ALLOW-NEW-GVALS]
|
||
|
||
ENTRY
|
||
|
||
MOVEI E,NOSETG
|
||
JRST FLGSET
|
||
|
||
; Subr to turn on and off allowing new LVALs
|
||
|
||
MFUNCTION %NEWLV,SUBR,[ALLOW-NEW-LVALS]
|
||
|
||
ENTRY
|
||
|
||
MOVEI E,NOSET
|
||
JRST FLGSET
|
||
|
||
; Change special unspecial normal mode
|
||
|
||
MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
|
||
|
||
ENTRY
|
||
|
||
CAMGE AB,[-3,,]
|
||
JRST TMA
|
||
MOVE C,SPCCHK ; GET CURRENT
|
||
JUMPGE AB,MODER ; RET CURRENT
|
||
GETYP 0,(AB) ; CHECK IT IS ATOM
|
||
CAIE 0,TATOM
|
||
JRST WTYP1
|
||
MOVE 0,1(AB)
|
||
MOVEI A,1
|
||
CAMN 0,MQUOTE UNSPECIAL
|
||
MOVSI A,(SETZ)
|
||
CAMN 0,MQUOTE SPECIAL
|
||
MOVEI A,0
|
||
JUMPG A,WTYP1
|
||
HLLM A,SPCCHK
|
||
|
||
MODER: MOVSI A,TATOM
|
||
MOVE B,MQUOTE SPECIAL
|
||
SKIPGE C
|
||
MOVE B,MQUOTE UNSPECIAL
|
||
JRST FINIS
|
||
|
||
; Function to turn special checking on and of
|
||
|
||
MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
|
||
|
||
ENTRY
|
||
CAMGE AB,[-3,,]
|
||
JRST TMA
|
||
|
||
MOVE C,SPCCHK
|
||
JUMPGE AB,SCHEK1
|
||
|
||
MOVEI A,0
|
||
GETYP 0,(AB)
|
||
CAIE 0,TFALSE
|
||
MOVEI A,1
|
||
HRRM A,SPCCHK
|
||
|
||
SCHEK1: TRNN C,1
|
||
JRST IFALS
|
||
JRST RETT
|
||
|
||
; Finction to set decls for GLOBAL values.
|
||
|
||
MFUNCTION GDECL,FSUBR
|
||
|
||
ENTRY 1
|
||
|
||
GETYP 0,(AB)
|
||
CAIE 0,TLIST
|
||
JRST WTYP1
|
||
|
||
PUSH TP,$TLIST
|
||
PUSH TP,1(AB)
|
||
PUSH TP,$TLIST
|
||
PUSH TP,[0]
|
||
PUSH TP,$TLIST
|
||
PUSH TP,[0]
|
||
|
||
GDECL1: INTGO
|
||
SKIPN C,1(TB)
|
||
JRST RETT
|
||
HRRZ D,(C) ; MAKE SURE PAIRS
|
||
JUMPE D,GDECLL ; LOSER, GO AWAY
|
||
GETYP 0,(C)
|
||
CAIE 0,TLIST
|
||
JRST GDECLL
|
||
HRRZ 0,(D)
|
||
MOVEM 0,1(TB) ; READY FOR NEXT CALL
|
||
MOVE C,1(C) ; SAVE ATOM LIST
|
||
MOVEM C,5(TB)
|
||
MOVEM D,3(TB)
|
||
|
||
GDECL2: INTGO
|
||
SKIPN C,5(TB)
|
||
JRST GDECL1 ; OUT OF ATOMS
|
||
GETYP 0,(C) ; IS THIS AN ATOM
|
||
CAIE 0,TATOM
|
||
JRST GDECLL ; NO, LOSE
|
||
MOVE B,1(C)
|
||
HRRZ C,(C)
|
||
MOVEM C,5(TB)
|
||
PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)
|
||
GETYP 0,(B) ; UNBOUND?
|
||
CAIE 0,TUNBOU
|
||
JRST CHKCUR ; CHECK CURRENT VALUE
|
||
MOVE C,3(TB) ; GET DECL
|
||
HRRM C,-2(B)
|
||
JRST GDECL2
|
||
|
||
CHKCUR: HRRZ D,3(TB)
|
||
GETYP A,(D)
|
||
MOVSI A,(A)
|
||
MOVE E,B
|
||
MOVE B,1(D)
|
||
MOVE C,(E)
|
||
MOVE D,1(E)
|
||
PUSH TP,$TVEC
|
||
PUSH TP,E
|
||
JSP E,CHKAB
|
||
PUSHJ P,TMATCH
|
||
JRST TYPMI3
|
||
MOVE E,(TP)
|
||
SUB TP,[2,,2]
|
||
MOVE D,3(TB)
|
||
HRRM D,-2(E)
|
||
JRST GDECL2
|
||
|
||
TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT
|
||
MOVE A,-1(E) ; ATOM TO A
|
||
MOVE B,1(E)
|
||
MOVE D,(E) ; GET OLD VALUE
|
||
MOVE C,3(TB)
|
||
JRST TYPMIS ; GO COMPLAIN
|
||
|
||
GDECLL: ERRUUO EQUOTE BAD-ARGUMENT-LIST
|
||
|
||
MFUNCTION UNMANIFEST,SUBR
|
||
|
||
ENTRY
|
||
|
||
PUSH P,[HLLZS -2(B)]
|
||
JRST MANLP
|
||
|
||
MFUNCTION MANIFEST,SUBR
|
||
|
||
ENTRY
|
||
|
||
PUSH P,[HLLOS -2(B)]
|
||
MANLP: JUMPGE AB,RETT
|
||
GETYP 0,(AB)
|
||
CAIE 0,TATOM
|
||
JRST WTYP
|
||
MOVE B,1(AB)
|
||
PUSHJ P,IIGLOC
|
||
XCT (P)
|
||
ADD AB,[2,,2]
|
||
JRST MANLP
|
||
|
||
MFUNCTION MANIFQ,SUBR,[MANIFEST?]
|
||
|
||
ENTRY 1
|
||
|
||
GETYP 0,(AB)
|
||
CAIE 0,TATOM
|
||
JRST WTYP1
|
||
|
||
MOVE B,1(AB)
|
||
PUSHJ P,IGLOC ; GET POINTER IF ANY
|
||
GETYP 0,A
|
||
CAIN 0,TUNBOU
|
||
JRST RETF
|
||
HRRZ 0,-2(B)
|
||
CAIE 0,-1
|
||
JRST RETF
|
||
JRST RETT
|
||
|
||
MFUNCTION GETDECL,SUBR,[GET-DECL]
|
||
|
||
ENTRY 1
|
||
|
||
GETYP 0,(AB)
|
||
CAIN 0,TOFFS
|
||
JRST GETDOF
|
||
PUSHJ P,GTLOC
|
||
JRST GTLOCA
|
||
|
||
HRRZ C,-2(B) ; GET GLOBAL DECL
|
||
GETD1: JUMPE C,RETF
|
||
CAIN C,-1
|
||
JRST RETMAN
|
||
GETYP A,(C)
|
||
MOVSI A,(A)
|
||
MOVE B,1(C)
|
||
JSP E,CHKAB
|
||
JRST FINIS
|
||
GETDOF: HLRZ B,1(AB)
|
||
JUMPE B,GETDO1
|
||
MOVE A,(B)
|
||
MOVE B,1(B)
|
||
JRST FINIS
|
||
GETDO1: MOVSI A,TATOM
|
||
MOVE B,IMQUOTE ANY
|
||
JRST FINIS
|
||
|
||
RETMAN: MOVSI A,TATOM
|
||
MOVE B,MQUOTE MANIFEST
|
||
JRST FINIS
|
||
|
||
GTLOCA: HLRZ C,2(B) ; LOCAL DECL
|
||
JRST GETD1
|
||
|
||
MFUNCTION PUTDECL,SUBR,[PUT-DECL]
|
||
|
||
ENTRY 2
|
||
|
||
GETYP 0,(AB)
|
||
CAIN 0,TOFFS
|
||
JRST PUTDOF ; MAKE OFFSET WITH NEW DECL
|
||
PUSHJ P,GTLOC
|
||
SKIPA E,[HRLM B,2(C)]
|
||
MOVE E,[HRRM B,-2(C)]
|
||
PUSH P,E
|
||
GETYP 0,(B) ; ANY VALUE
|
||
CAIN 0,TUNBOU
|
||
JRST PUTD1
|
||
MOVE C,(B) ; GET CURRENT VALUE
|
||
MOVE D,1(B)
|
||
MOVE A,2(AB)
|
||
MOVE B,3(AB)
|
||
PUSHJ P,TMATCH
|
||
JRST TYPMI4
|
||
PUTD1: MOVE C,2(AB) ; GET DECL BACK
|
||
MOVE D,3(AB)
|
||
PUSHJ P,INCONS ; CONS IT UP
|
||
MOVE C,1(AB) ; LOCATIVE BACK
|
||
XCT (P) ; CLOBBER
|
||
MOVE A,(AB)
|
||
MOVE B,1(AB)
|
||
JRST FINIS
|
||
|
||
TYPMI4: MOVE E,1(AB) ; GET LOCATIVE
|
||
MOVE A,-1(E) ; NOW ATOM
|
||
MOVEI C,2(AB) ; POINT TO DECL
|
||
MOVE D,(E) ; AND CURRENT VAL
|
||
MOVE B,1(E)
|
||
JRST TYPMIS
|
||
|
||
GTLOC: GETYP 0,(AB)
|
||
CAIE 0,TLOCD
|
||
JRST WTYP1
|
||
MOVEI B,(AB)
|
||
PUSHJ P,CHLOCI
|
||
HRRZ 0,(AB) ; LOCAL OR GLOBAL
|
||
SKIPN 0
|
||
AOS (P)
|
||
MOVE B,1(AB) ; RETURN LOCATIVE IN B
|
||
POPJ P,
|
||
|
||
; MAKE OFFSET WITH SUPPLIED DECL
|
||
PUTDOF: MOVE D,3(AB)
|
||
GETYP 0,2(AB)
|
||
CAIN TATOM
|
||
CAME D,IMQUOTE ANY
|
||
JRST PUTDO1
|
||
MOVSI A,TOFFS
|
||
HRRZ B,1(AB)
|
||
JRST FINIS
|
||
PUTDO1: MOVE C,2(AB)
|
||
PUSHJ P,INCONS ; BUILD A LIST
|
||
MOVSI A,TOFFS
|
||
HRLS B
|
||
HRR B,1(AB) ; SET UP OFFSET
|
||
JRST FINIS
|
||
|
||
; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM)
|
||
; JUMPS INTO PUT-DECL CODE FOR OFFSETS.
|
||
MFUNCTION COFFSET,SUBR,[OFFSET]
|
||
|
||
ENTRY 2
|
||
GETYP 0,(AB)
|
||
CAIE 0,TFIX
|
||
JRST WTYP1
|
||
SKIPG 1(AB)
|
||
JRST OUTRNG ; CAN'T HAVE NEGATIVE OFFSETS
|
||
GETYP 0,2(AB)
|
||
CAIE 0,TATOM
|
||
CAIN 0,TFORM
|
||
JRST PUTDOF
|
||
JRST WTYP2
|
||
|
||
; GET FIX PART OF OFFSET
|
||
MFUNCTION INDEX,SUBR
|
||
|
||
ENTRY 1
|
||
GETYP 0,(AB)
|
||
CAIE 0,TOFFS
|
||
JRST WTYP1
|
||
MOVSI A,TFIX
|
||
HRRE B,1(AB)
|
||
JRST FINIS
|
||
|
||
; Interface between EVAL and declaration processor.
|
||
; E points into stack at a binding and C points to decl list.
|
||
|
||
CHKDCL: SKIPE IGDECL ; IGNORING DECLS?
|
||
POPJ P, ; YUP, JUST LEAVE
|
||
|
||
PUSH TP,$TTP ; SAVE BINDING
|
||
PUSH TP,E
|
||
MOVE A,-4(E) ; GET ATOM
|
||
MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE
|
||
MOVE PVP,PVSTOR+1
|
||
MOVEM 0,CSTO(PVP)
|
||
MOVEM 0,BSTO(PVP)
|
||
MOVSI 0,TATOM
|
||
MOVEM 0,ASTO(PVP)
|
||
SETZB B,0 ; CLOBBER FOR INTGO
|
||
|
||
DCL2: INTGO
|
||
HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS
|
||
JUMPE D,BADCL
|
||
GETYP B,(C) ; MUST BE LIST OF ATOMS
|
||
CAIE B,TLIST
|
||
JRST BADCL
|
||
MOVE B,1(C) ; GET LIST
|
||
|
||
DCL1: INTGO
|
||
CAMN A,1(B) ; SKIP IF NOT WINNER
|
||
JRST DCLQ ; MAY BE WINNER
|
||
DCL3: HRRZ B,(B) ; CDR ON
|
||
JUMPN B,DCL1 ; JUMP IF MORE
|
||
|
||
HRRZ C,(D) ; CDR MAIN LIST
|
||
JUMPN C,DCL2 ; AND JUMP IF WINNING
|
||
|
||
PUSHJ P,E.GET ; GET BINDING BACK
|
||
SUB TP,[2,,2] ; POP OF JUNK
|
||
POPJ P,
|
||
|
||
DCLQ: GETYP C,(B) ; CHECK ATOMIC
|
||
CAIE C,TATOM
|
||
JRST BADCL ; LOSER
|
||
PUSHJ P,E.GET ; GOT IT
|
||
PUSH TP,$TLIST ; SAVE PATTERN
|
||
PUSH TP,D
|
||
MOVE B,1(D) ; GET PATTERN
|
||
HLLZ A,(D)
|
||
MOVE C,-3(E) ; PROPOSED VALUE
|
||
MOVE D,-2(E)
|
||
PUSHJ P,TMATCH ; MATCH TYPE
|
||
JRST TYPMI1 ; LOSER
|
||
DCLQ1: MOVE E,-2(TP)
|
||
MOVE C,-5(E) ; CHECK FOR SPEC CHANGE
|
||
SKIPE 0 ; MAKE SURE NON ZERO IS -1
|
||
MOVNI 0,1
|
||
SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL
|
||
SETCM 0 ; COMPLEMENT
|
||
ANDI 0,1 ; ONE BIT
|
||
CAMN C,[TATOM,,-1]
|
||
JRST .+3
|
||
CAME C,[TATOM,,-2]
|
||
JRST .+3
|
||
ANDCMI C,1
|
||
IOR C,0 ; MUNG BIT
|
||
MOVEM C,-5(E)
|
||
HRRZ C,(TP)
|
||
SUB TP,[4,,4]
|
||
MOVEM C,(E) ; STORE DECLS
|
||
MOVSI C,TLIST
|
||
MOVEM C,-1(E)
|
||
POPJ P,
|
||
|
||
TYPMI1: MOVE E,-2(TP)
|
||
GETYP C,-3(E)
|
||
CAIN C,TUNBOU
|
||
JRST DCLQ1
|
||
MOVE E,-2(TP) ; GET POINTER TO BIND
|
||
MOVE D,-3(E) ; GET VAL
|
||
MOVE B,-2(E)
|
||
HRRZ C,(TP) ; DCL LIST
|
||
MOVE A,-4(E) ; GET ATOM
|
||
SUB TP,[4,,4]
|
||
TYPMIS: PUSH TP,$TATOM
|
||
PUSH TP,EQUOTE TYPE-MISMATCH
|
||
PUSH TP,$TATOM
|
||
PUSH TP,A
|
||
PUSH TP,(C)
|
||
HLLZS (TP)
|
||
PUSH TP,1(C)
|
||
JSP E,CHKARG ; HACK DEFER
|
||
PUSH TP,D
|
||
PUSH TP,B
|
||
MOVEI A,4 ; 3 ERROR ARGS
|
||
JRST CALER
|
||
|
||
BADCL: PUSHJ P,E.GET
|
||
ERRUUO EQUOTE BAD-DECLARATION-LIST
|
||
|
||
; ROUTINE TO RESSET INT STUFF
|
||
|
||
E.GET: MOVE E,(TP)
|
||
MOVE PVP,PVSTOR+1
|
||
SETZM ASTO(PVP)
|
||
SETZM BSTO(PVP)
|
||
SETZM CSTO(PVP)
|
||
POPJ P,
|
||
|
||
; Declarations processor for MUDDLE type declarations.
|
||
; Receives a pattern in a and B and an object in C and D.
|
||
; It skip returns if the object fits otherwise it doesn't.
|
||
; Declaration syntax errors are caught and sent to ERROR.
|
||
|
||
TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR
|
||
SKIPE IGDECL ; IGNORING DECLS?
|
||
JRST CPOPJ1 ; YUP, ACT LIKE THEY WON
|
||
|
||
TMATCX: GETYP 0,A ; GET PATTERNS TYPE
|
||
CAIE 0,TSEG
|
||
CAIN 0,TFORM ; MUST BE FORM OR ATOM
|
||
JRST TMAT1
|
||
CAIE 0,TATOM
|
||
JRST TERR1 ; WRONG TYPE FOR A DCL
|
||
|
||
; SIMPLE TYPE MATCHER
|
||
|
||
TYPMAT: GETYP E,C ; OBJECTS TYPE TO E
|
||
PUSH P,E ; SAVE IT
|
||
PUSH TP,C
|
||
PUSH TP,D
|
||
PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE
|
||
JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS
|
||
SUB TP,[2,,2]
|
||
POP P,E ; RESTORE TYPE OF OBJECT
|
||
MOVEI 0,0 ; SPECIAL INDICATOR
|
||
CAIN E,(D) ; SKIP IF LOSERS
|
||
CPOPJ1: AOS (P) ; GOOD RETURN
|
||
CPOPJ: POPJ P,
|
||
|
||
SPECS: POP P,A ; RESTORE OBJECTS TYPE
|
||
POP TP,D
|
||
POP TP,C
|
||
CAMN B,IMQUOTE ANY
|
||
JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS
|
||
CAMN B,IMQUOTE STRUCTURED
|
||
JRST ISTRUC ; LET ISTRUC DO THE WORK
|
||
CAMN B,IMQUOTE APPLICABLE
|
||
JRST APLQ
|
||
CAMN B,IMQUOTE LOCATIVE
|
||
JRST LOCQQ
|
||
PUSH TP,$TATOM
|
||
PUSH TP,B
|
||
PUSH TP,C
|
||
PUSH TP,D
|
||
MOVSI A,TATOM
|
||
MOVSI C,TATOM
|
||
MOVE D,IMQUOTE DECL
|
||
PUSHJ P,IGET
|
||
JUMPE B,TERR2X
|
||
MOVEM A,-3(TP)
|
||
MOVEM B,-2(TP)
|
||
INTGO
|
||
POP TP,D
|
||
POP TP,C
|
||
POP TP,B
|
||
POP TP,A
|
||
JRST TMATCX
|
||
|
||
; ARRIVE HERE FOR A FORM IN THE DCLS
|
||
|
||
TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES
|
||
HRRZ E,(B) ; CDR IT
|
||
JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE
|
||
PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0
|
||
JRST TEXP1 ; NOT ATOM
|
||
CAME 0,MQUOTE SPECIAL
|
||
CAMN 0,MQUOTE UNSPECIAL
|
||
JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL
|
||
TMAT3: PUSHJ P,TEXP1
|
||
JRST .+2
|
||
AOS (P)
|
||
MOVEI 0,0 ; RET UNSPECIAL INDICATION
|
||
POPJ P,
|
||
|
||
TEXP1: JUMPE B,TERR3 ; EMPTY FORM
|
||
GETYP E,A ; CHECK CURRENT TYPE
|
||
CAIN E,TATOM ; IF ATOM,
|
||
JRST TYPMA1 ; SIMPLE MATCH
|
||
CAIN E,TSEG
|
||
JRST .+3
|
||
CAIE E,TFORM
|
||
JRST TERR4
|
||
GETYP 0,(B) ; WHAT IS FIRST ELEMEMT
|
||
CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
|
||
JRST TEXP12
|
||
PUSH TP,$TLIST ; SAVE LIST
|
||
PUSH TP,B
|
||
MOVE B,1(B) ; GET FORM
|
||
PUSH TP,C
|
||
PUSH TP,D
|
||
PUSH P,E
|
||
PUSHJ P,ACTRT1
|
||
TDZA 0,0 ; REMEMBER LACK OF SKIP
|
||
MOVEI 0,1
|
||
POP P,E
|
||
POP TP,D
|
||
POP TP,C
|
||
MOVE B,(TP) ; GET BACK SAVED LIST
|
||
SUB TP,[2,,2]
|
||
JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY
|
||
HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
|
||
|
||
; CHECKS TYPES OF ELEMENTS OF STRUCTURES
|
||
|
||
ELETYP: CAIE E,TSEG ; MUST BE EXAXT?
|
||
JUMPE B,CPOPJ1 ; EMPTY=> WON
|
||
PUSH TP,$TLIST ; SAVE DCL LIST
|
||
PUSH TP,B
|
||
MOVE A,C ; GET OBJ IN A AND B
|
||
MOVE B,D
|
||
CAIE E,TSEG
|
||
TDZA E,E
|
||
MOVNI E,1
|
||
PUSH P,E
|
||
PUSHJ P,TYPSGR ; GET REST/NTH CODE
|
||
JRST ELETYL ; LOSER
|
||
CAIN C,5 ; BYTE STRING COMES HERE
|
||
JRST ELEBYT ; HACK IT
|
||
PUSH TP,DSTORE
|
||
PUSH TP,D
|
||
PUSH P,C ; SAVE CODE
|
||
PUSH TP,[0] ; AND SLOTS
|
||
PUSH TP,[0]
|
||
|
||
; MAIN ELEMENT SCANNING LOOP
|
||
|
||
ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY
|
||
JRST ELETY2 ; CHEK EMPTY WINNER
|
||
SKIPN -4(TP)
|
||
JRST ELETY4
|
||
XCT TYPG(C) ; GET ELEMENT
|
||
XCT VALG(C)
|
||
JSP E,CHKAB ; CHECK OUT DEFER
|
||
MOVEM A,-1(TP) ; AND SAVE IT
|
||
MOVEM B,(TP)
|
||
MOVE C,A
|
||
MOVE D,B ; FOR OTHER MATCHERS
|
||
MOVE B,-4(TP) ; GET PATTERN
|
||
MOVE A,(B)
|
||
GETYP 0,(B) ; GET TYPE OF <1 pattern>
|
||
MOVE B,1(B) ; GET ATOM OR WHATEVER
|
||
CAIE 0,TATOM ; ATOM ... SIMPLE TYPE
|
||
JRST ELETY3
|
||
PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH
|
||
JRST ELETY4 ; LOSER
|
||
|
||
; HERE TO REST EVERYTHING AND GO ON BACK
|
||
|
||
ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER
|
||
MOVE C,(P) ; GET INCREMENT CODE
|
||
XCT INCR1(C)
|
||
MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR
|
||
MOVE 0,DSTORE
|
||
MOVEM 0,-3(TP)
|
||
|
||
ELETY9: HRRZ B,@-4(TP) ; CDR IT
|
||
MOVEM B,-4(TP)
|
||
JUMPN B,ELETY1
|
||
|
||
SKIPN -1(P) ; SKIP IF EXACT REQUIRED
|
||
JRST ELETY8
|
||
XCT TESTR(C)
|
||
JRST ELETY8
|
||
JRST ELETY4
|
||
|
||
|
||
; HERE IF PATTERN EMPTY
|
||
|
||
ELETY8: AOS -2(P) ; SKIP RETURN
|
||
ELETY4: SETZM DSTORE
|
||
SUB P,[2,,2]
|
||
SUB TP,[6,,6]
|
||
POPJ P,
|
||
|
||
ELETYL: SUB P,[1,,1]
|
||
SUB TP,[2,,2]
|
||
POPJ P,
|
||
|
||
; HERE TO HANDLE EMPTY OBJECT
|
||
|
||
ELETY2: MOVE B,-4(TP) ; GET PATTERN
|
||
JUMPE B,ELETY8
|
||
GETYP 0,(B) ; CHECK FOR [REST ...]
|
||
SETZM DSTORE
|
||
CAIE 0,TVEC
|
||
JRST ELETY4 ; LOSER
|
||
HLRZ 0,1(B) ; SIZE OF IT
|
||
CAILE 0,-4 ; MUST BE 2
|
||
JRST ELETY4
|
||
MOVE B,1(B) ; GET IT
|
||
PUSHJ P,0ATGET ; LOOK FOR REST
|
||
JRST ELETY4
|
||
CAMN 0,MQUOTE OPTIONAL
|
||
JRST ELETY8
|
||
CAME 0,MQUOTE OPT
|
||
CAMN 0,IMQUOTE REST
|
||
JRST ELETY8 ; WINNER!!!!
|
||
JRST ELETY4 ; LOSER
|
||
|
||
; HERE TO CHECK OUT A FORM ELEMNT
|
||
|
||
ELETY3: CAIN 0,TSEG
|
||
JRST ELGO
|
||
CAIE 0,TFORM
|
||
JRST ELETY7
|
||
ELGO: SETZM DSTORE
|
||
PUSHJ P,TEXP1 ; AND ANALYSE IT
|
||
JRST ELETY4 ; LOSER
|
||
MOVE 0,-3(TP) ; RESET DSTO
|
||
MOVEM 0,DSTORE
|
||
JRST ELETY6 ; WINNER
|
||
|
||
; CHECK FOR VECTOR IN PATTERN
|
||
|
||
ELETY7: CAIE 0,TVEC ; SKIP IF WINNER
|
||
JRST TERR12 ; YET ANOTHER ERROR
|
||
HLRE C,B ; CHECK LEENGTH
|
||
CAMLE C,[-4] ; MUST BE 2 LONG
|
||
JRST TERR13
|
||
PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?
|
||
JRST ELET71 ; COULD BE FORM
|
||
CAME 0,MQUOTE OPT
|
||
CAMN 0,MQUOTE OPTIONAL
|
||
JRST ELET72
|
||
CAME 0,IMQUOTE REST
|
||
JRST TERR14
|
||
MOVE 0,(P) ; GET STRUC CODE
|
||
CAIN 0,2
|
||
CAME C,[-4]
|
||
JRST ELNUVE
|
||
|
||
GETYP 0,2(B) ; SEE IF UVECTOR REST SIMPLE TYPE
|
||
CAIE 0,TATOM
|
||
JRST ELNUVE
|
||
|
||
MOVE C,3(B) ; GET ATOM
|
||
HLRE 0,C
|
||
SUB C,0 ; POINT TO DOPE WDS
|
||
HRRE 0,(C)
|
||
JUMPE 0,ELNUVE
|
||
MOVSI A,TATOM
|
||
MOVE B,3(B)
|
||
MOVE C,-2(TP)
|
||
HLRE D,C
|
||
SUB C,D
|
||
GETYP C,(C)
|
||
MOVSI C,(C)
|
||
PUSHJ P,TMATCX
|
||
JRST ELETY4
|
||
JRST ELETY8
|
||
|
||
ELNUVE: TDOA 0,[-1]
|
||
ELET72: MOVSI 0,(SETZ) ; FLAG USED IN RESTIT
|
||
PUSH P,0
|
||
PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR
|
||
JRST ELET41
|
||
POP P,0
|
||
TRNE 0,-1
|
||
JRST ELETY8 ; WIN AND DONE
|
||
JRST ELET81
|
||
|
||
ELET41: SUB P,[1,,1]
|
||
JRST ELETY4
|
||
|
||
; CHECK FOR [fix .... ]
|
||
|
||
ELET71: CAIE 0,TFIX
|
||
JRST TERR15
|
||
MOVNS C
|
||
ASH C,-1
|
||
MOVE 0,1(B) ; GET NUMBER
|
||
IMULI 0,-1(C) ; COUNT MORE
|
||
PUSH P,0
|
||
PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS
|
||
TDZA 0,0
|
||
MOVEI 0,1
|
||
SUB P,[1,,1]
|
||
JUMPE 0,ELETY4
|
||
ELET81: MOVE D,-2(TP) ; GET OBJECT BACK
|
||
MOVE 0,-3(TP) ; RESET DSTO
|
||
MOVEM 0,DSTORE
|
||
MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.
|
||
JRST ELETY9
|
||
|
||
|
||
; HERE TO DO A TASTEFUL TYPMAT
|
||
|
||
TYPMA1: PUSH TP,C
|
||
PUSH TP,D
|
||
PUSHJ P,TYPMAT
|
||
TDZA 0,0 ; REMEMBER LOSSAGE
|
||
MOVEI 0,1 ; OR WINNAGE
|
||
POP TP,D
|
||
POP TP,C ; RESTORE OBJECT
|
||
JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN
|
||
POPJ P,
|
||
|
||
; HERE TO SKIP SPECIAL/UNSPECIAL
|
||
|
||
TMAT2: CAME 0,MQUOTE SPECIAL
|
||
TDZA 0,0
|
||
MOVEI 0,1
|
||
PUSH P,0 ; SAVE INDICATOR
|
||
HRRZ A,(E) ; CHECK FOR EXACT LENGTH
|
||
JUMPN A,TERR16
|
||
GETYP A,(E) ; TYPE OF NEW PAT
|
||
MOVE B,1(E) ; VALUE
|
||
MOVSI A,(A)
|
||
PUSHJ P,TEXP1
|
||
JRST .+2
|
||
AOS -1(P)
|
||
POP P,0
|
||
POPJ P,
|
||
|
||
; LOOK FOR <OR... OR <PRIMTYPE....
|
||
|
||
TEXP12: CAIE 0,TATOM
|
||
JRST TERR5
|
||
MOVE 0,1(B) ; GET ATOM
|
||
CAMN 0,IMQUOTE QUOTE
|
||
JRST MQUOT ; MATCH A QUOTED OBJECT
|
||
CAME 0,IMQUOTE OR
|
||
CAMN 0,IMQUOTE PRIMTYPE
|
||
JRST ACTORT ; FALL INTO ACTOR HACKER
|
||
PUSH TP,$TLIST
|
||
PUSH TP,B
|
||
MOVE B,0 ; GET ATOM
|
||
PUSH TP,C ; SAVE OBJ
|
||
PUSH TP,D
|
||
PUSH P,E
|
||
PUSHJ P,TYPMAT
|
||
TDZA 0,0
|
||
MOVEI 0,1
|
||
POP P,E
|
||
MOVE C,-1(TP)
|
||
MOVE D,(TP)
|
||
MOVE B,-2(TP)
|
||
JUMPN 0,.+3 ; TO ELETYP IF WON
|
||
SUB TP,[4,,4]
|
||
POPJ P, ; ELSE LOSE
|
||
|
||
HRRZ 0,(B)
|
||
MOVSI A,TFORM
|
||
JUMPE 0,TERR3
|
||
MOVE B,0
|
||
PUSHJ P,ELETYP
|
||
FOOPC: TDZA 0,0
|
||
MOVEI 0,1
|
||
POPPIT: POP TP,D
|
||
POP TP,C
|
||
POP TP,B
|
||
POP TP,A
|
||
JUMPN 0,CPOPJ1
|
||
POPJ P,
|
||
|
||
; THIS CODE HANDLES ORs AND PRIMTYPEs
|
||
ACTRT1: SKIPA E,[SETZ PACT]
|
||
|
||
ACTORT: MOVE E,[SETZ TEXP1]
|
||
JUMPE B,TERR6 ; EMPTY, LOSE
|
||
PUSHJ P,0ATGET ; ATOM TO 0
|
||
JRST PACT
|
||
CAME 0,IMQUOTE OR
|
||
JRST PACT2
|
||
HRRZ 0,(B) ; REST IT FLUSHING OR
|
||
JUMPE 0,TERR7
|
||
PUSH TP,$TLIST ; SAVE LSIT
|
||
PUSH TP,0
|
||
PUSH P,E ; SAVE ELEMENT CHECKER
|
||
|
||
ORLP: SKIPN B,(TP) ; ANY LEFT?
|
||
JRST ORDON ; NOPE, LOSE
|
||
HRRZ 0,(B) ; SAVE THE REST
|
||
MOVEM 0,(TP)
|
||
GETYP 0,(B) ; WHAT ARE WE ORing
|
||
MOVE A,(B) ; TYPE WORD
|
||
MOVE B,1(B) ; AND ITEM
|
||
PUSH TP,C
|
||
PUSH TP,D
|
||
PUSHJ P,@(P) ; EITHER PACT OR TEXP1
|
||
TDZA 0,0
|
||
MOVEI 0,1
|
||
POP TP,D
|
||
POP TP,C
|
||
JUMPE 0,ORLP
|
||
AOS -1(P) ; SKIP RETURN FOR WINNER
|
||
|
||
ORDON: SUB TP,[2,,2] ; FLUSH TEMP
|
||
SUB P,[1,,1]
|
||
POPJ P,
|
||
|
||
; HERE TO PRIMTYPE ACTORS
|
||
|
||
PACT: CAIE 0,TFORM
|
||
JRST PACT1
|
||
JUMPE B,TERR6 ; EMPTY FORM
|
||
MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE
|
||
PACT2: CAME 0,IMQUOTE PRIMTYPE
|
||
JRST TERR7
|
||
HRRZ A,(B) ; GET PRIMTYPE
|
||
JUMPE A,TERR7
|
||
HRRZ 0,(A)
|
||
JUMPN 0,TERR18
|
||
MOVEI B,(A)
|
||
GETYP A,C ; GET OBJ TYPE
|
||
GETYP 0,(B) ; GET PATTERN TYPE
|
||
CAIE 0,TATOM ; BETTER BE ATOM
|
||
JRST TERR8
|
||
PUSH TP,$TLIST ; SAVE DCL LIST
|
||
PUSH TP,B
|
||
PUSH TP,C
|
||
PUSH TP,D
|
||
PUSHJ P,SAT ; GET STORAGE TYPE
|
||
CAILE A,NUMSAT
|
||
JRST PTEMP
|
||
MOVE B,@STBL(A) ; GET PRIM NAME
|
||
PUSHJ P,TYPFND
|
||
JFCL ; MUST EXIST
|
||
MOVSI C,(D) ; FAKE OUT TYPMAT
|
||
MOVE B,-2(TP)
|
||
MOVE B,1(B)
|
||
PUSHJ P,TYPMAT
|
||
JRST .+2
|
||
AOS (P)
|
||
MOVE C,-1(TP)
|
||
MOVE D,(TP)
|
||
SUB TP,[4,,4]
|
||
POPJ P,
|
||
|
||
PACT1: CAIE 0,TATOM
|
||
JRST TERR4
|
||
JRST TYPMAT
|
||
|
||
PTEMP: MOVE B,-2(TP)
|
||
MOVE B,1(B)
|
||
CAMN B,IMQUOTE TEMPLATE
|
||
AOS (P)
|
||
SUB TP,[4,,4]
|
||
POPJ P,
|
||
|
||
; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
|
||
|
||
RESTIT: PUSH TP,$TVEC ; SAVE TYPE
|
||
ADD B,[2,,2] ; SKIP OVER CRUFT
|
||
PUSH TP,B ; AND VAL
|
||
PUSH TP,$TVEC
|
||
PUSH TP,B
|
||
RESTI1: PUSH P,A ; SAVE DISP HACK
|
||
PUSH P,0 ; AND COUNT HACK
|
||
RESTI4: SKIPL (P) ; SKIP IF DOING ALL
|
||
SOSL (P) ; SKIP IF DONE
|
||
JRST RESTI6
|
||
AOS -2(P) ; SKIP RET
|
||
RESTI5: SUB P,[2,,2] ; POP JUNK
|
||
SUB TP,[4,,4]
|
||
POPJ P,
|
||
RESTI6: SKIPGE (TP)
|
||
JRST RESTX1
|
||
HLRZ 0,(P)
|
||
CAIN 0,(SETZ)
|
||
JRST RESTI2
|
||
RESTX1: MOVE C,-4(P) ; REST CODE
|
||
MOVE D,-6(TP) ; SET UP FOR REST
|
||
MOVE E,-7(TP) ; DONT FORGET DSTO
|
||
MOVEM E,DSTORE
|
||
XCT TESTR(C) ; DONE?
|
||
JRST RESTI2 ; YES, CHECK WINNAGE
|
||
XCT TYPG(C)
|
||
XCT VALG(C) ; GET VAL ANDTYPE
|
||
JSP E,CHKAB ; CHECK DEFER
|
||
XCT INCR1(C) ; REST IT
|
||
MOVEM D,-6(TP) ; SAVE LIST
|
||
MOVE E,DSTORE
|
||
MOVEM E,-7(TP) ; FIXUP
|
||
SETZM DSTORE
|
||
MOVE C,A
|
||
MOVE D,B
|
||
SKIPL A,(TP) ; ANY MORE?
|
||
MOVE A,-2(TP) ; NO RECYCLE
|
||
ADD A,[2,,2] ; BUMP
|
||
MOVEM A,(TP) ; AND SAVE
|
||
MOVE B,-1(A) ; GET ELEMENT
|
||
MOVE A,-2(A)
|
||
GETYP 0,A
|
||
MOVEI E,TERR15
|
||
CAIN 0,TATOM
|
||
MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE
|
||
CAIE 0,TSEG
|
||
CAIN 0,TFORM ; FORM--> HAIRY PATTERN
|
||
MOVEI E,TEXP1
|
||
TLO E,400000
|
||
PUSHJ P,(E) ; DO IT
|
||
JRST RESTI5
|
||
JRST RESTI4
|
||
|
||
RESTI2: SKIPGE (P) ; SKIP IF WON
|
||
AOS -2(P) ; COUNTERACT CPOPJ1
|
||
JRST RESTI5
|
||
|
||
RESTI3: TEXP1
|
||
TYPMAT
|
||
|
||
; HERE TO MATHC A QUOTED OBJ
|
||
; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST
|
||
|
||
MQUOT: HRRZ B,(B) ; LOOK AT NEXT
|
||
JUMPE B,TERR7
|
||
GETYP A,(B) ; GET TYPE
|
||
MOVSI A,(A)
|
||
MOVE B,1(B) ; AND VALUE
|
||
JSP E,CHKAB ; HACK DEFER
|
||
PUSH TP,A
|
||
PUSH TP,B
|
||
PUSH TP,C
|
||
PUSH TP,D
|
||
MOVEI D,-3(TP)
|
||
MOVEI C,-1(TP)
|
||
PUSHJ P,IEQUAL
|
||
TDZA 0,0
|
||
MOVEI 0,1
|
||
JRST POPPIT
|
||
|
||
; HERE TO HANDLE SPECIAL BYTE STRING HAIR
|
||
|
||
ELEBYT: MOVE B,(TP) ; GET DECL LIST BACK
|
||
POP P,E ; EXACTNESS FLAG
|
||
JUMPE B,ELEBY2
|
||
GETYP 0,(B)
|
||
CAIE 0,TFIX
|
||
JRST TERR17
|
||
MOVE A,1(B)
|
||
HRRZ B,(B)
|
||
HRRZ 0,(B)
|
||
SKIPE B
|
||
JUMPN 0,TERR17
|
||
LDB C,[300600,,D] ; GET BYTE SIZE
|
||
CAIE A,(C)
|
||
JRST ELEBY3
|
||
HRRZ C,DSTORE
|
||
ELEBY2: MOVEI A,0
|
||
JUMPE B,ELEBY4
|
||
GETYP 0,(B)
|
||
CAIE 0,TFIX
|
||
JRST TERR17
|
||
MOVE A,1(B)
|
||
ELEBY4: CAIGE C,(A)
|
||
JRST ELEBY3
|
||
CAIE A,(C)
|
||
JUMPN E,ELEBY3
|
||
AOS (P)
|
||
ELEBY3: SETZM DSTORE
|
||
SUB TP,[2,,2]
|
||
POPJ P,
|
||
|
||
|
||
|
||
; GET ATOM IN AC 0
|
||
|
||
0ATGET: GETYP 0,(B)
|
||
CAIE 0,TATOM ; SKIP IF ATOM
|
||
POPJ P,
|
||
MOVE 0,1(B) ; GET ATOM
|
||
JRST CPOPJ1
|
||
|
||
TERR17: MOVE B,-2(TP)
|
||
MOVE B,1(B)
|
||
HRRZ 0,(P)
|
||
CAIN 0,FOOPC
|
||
MOVE B,-4(TP)
|
||
MOVSI A,TFORM
|
||
MOVE E,EQUOTE BAD-BYTES-DECL
|
||
SETZM DSTORE
|
||
JRST TERRD
|
||
|
||
TERR18: SKIPA E,EQUOTE TOO-MANY-ARGS-TO-PRIMTYPE-DECL
|
||
TERR16: MOVE E,EQUOTE TOO-MANY-ARGS-TO-SPECIAL-UNSPECIAL-DECL
|
||
MOVSI A,TFORM
|
||
JRST TERRD
|
||
|
||
TERR9: MOVS A,0 ; TYPE TO A
|
||
TERR4:
|
||
TERR5:
|
||
TERR15:
|
||
TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
|
||
JRST TERRD
|
||
|
||
TERR2X: SUB TP,[2,,2]
|
||
POP TP,B
|
||
POP TP,A
|
||
|
||
TERR2: MOVSI A,TATOM
|
||
MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
|
||
JRST TERRD
|
||
TERR6:
|
||
TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL
|
||
JRST TERRD
|
||
TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
|
||
JRST TERRD
|
||
|
||
TERR8: MOVS A,0 ; TYPE TO A
|
||
MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
|
||
JRST TERRD
|
||
TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
|
||
JRST TERRD
|
||
TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
|
||
JRST TERRD
|
||
TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
|
||
|
||
TERRD: PUSH TP,$TATOM
|
||
PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION
|
||
PUSH TP,$TATOM
|
||
PUSH TP,E
|
||
PUSH TP,A
|
||
PUSH TP,B
|
||
MOVEI A,3
|
||
JRST CALER
|
||
|
||
IMPURE
|
||
|
||
IGDECL: 0
|
||
|
||
PURE
|
||
|
||
END
|
||
|