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