--- /dev/null
+
+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
+\f
+; 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
+\f\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff