2 TITLE DECLARATION PROCESSOR
8 .GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT
9 .GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC
10 .GLOBAL CHLOCI,INCONS,SPCCHK,OUTRNG,WTYP1,FLGSET,IGET,PVSTOR,SPSTOR,DSTORE
11 .GLOBAL NOATMS,NOSET,NOSETG
12 ; Subr to allow user to access the DECL checking code
14 MFUNCTION CHECKD,SUBR,[DECL?]
22 PUSHJ P,TMATCX ; CHECK THEM
34 ; Subr to turn DECL checking on and off.
36 MFUNCTION %DECL,SUBR,[DECL-CHECK]
43 ; Subr to turn on and off allowing new atoms
45 MFUNCTION %NEWAT,SUBR,[ALLOW-NEW-ATOMS]
52 ; Subr to turn on and off allowing new GVALS
54 MFUNCTION %NEWGV,SUBR,[ALLOW-NEW-GVALS]
61 ; Subr to turn on and off allowing new LVALs
63 MFUNCTION %NEWLV,SUBR,[ALLOW-NEW-LVALS]
70 ; Change special unspecial normal mode
72 MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
78 MOVE C,SPCCHK ; GET CURRENT
79 JUMPGE AB,MODER ; RET CURRENT
80 GETYP 0,(AB) ; CHECK IT IS ATOM
85 CAMN 0,MQUOTE UNSPECIAL
95 MOVE B,MQUOTE UNSPECIAL
98 ; Function to turn special checking on and of
100 MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
119 ; Finction to set decls for GLOBAL values.
121 MFUNCTION GDECL,FSUBR
139 HRRZ D,(C) ; MAKE SURE PAIRS
140 JUMPE D,GDECLL ; LOSER, GO AWAY
145 MOVEM 0,1(TB) ; READY FOR NEXT CALL
146 MOVE C,1(C) ; SAVE ATOM LIST
152 JRST GDECL1 ; OUT OF ATOMS
153 GETYP 0,(C) ; IS THIS AN ATOM
155 JRST GDECLL ; NO, LOSE
159 PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)
160 GETYP 0,(B) ; UNBOUND?
162 JRST CHKCUR ; CHECK CURRENT VALUE
163 MOVE C,3(TB) ; GET DECL
185 TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT
186 MOVE A,-1(E) ; ATOM TO A
188 MOVE D,(E) ; GET OLD VALUE
190 JRST TYPMIS ; GO COMPLAIN
192 GDECLL: ERRUUO EQUOTE BAD-ARGUMENT-LIST
194 MFUNCTION UNMANIFEST,SUBR
201 MFUNCTION MANIFEST,SUBR
206 MANLP: JUMPGE AB,RETT
216 MFUNCTION MANIFQ,SUBR,[MANIFEST?]
225 PUSHJ P,IGLOC ; GET POINTER IF ANY
234 MFUNCTION GETDECL,SUBR,[GET-DECL]
244 HRRZ C,-2(B) ; GET GLOBAL DECL
258 GETDO1: MOVSI A,TATOM
262 RETMAN: MOVSI A,TATOM
263 MOVE B,MQUOTE MANIFEST
266 GTLOCA: HLRZ C,2(B) ; LOCAL DECL
269 MFUNCTION PUTDECL,SUBR,[PUT-DECL]
275 JRST PUTDOF ; MAKE OFFSET WITH NEW DECL
277 SKIPA E,[HRLM B,2(C)]
278 MOVE E,[HRRM B,-2(C)]
280 GETYP 0,(B) ; ANY VALUE
283 MOVE C,(B) ; GET CURRENT VALUE
289 PUTD1: MOVE C,2(AB) ; GET DECL BACK
291 PUSHJ P,INCONS ; CONS IT UP
292 MOVE C,1(AB) ; LOCATIVE BACK
298 TYPMI4: MOVE E,1(AB) ; GET LOCATIVE
299 MOVE A,-1(E) ; NOW ATOM
300 MOVEI C,2(AB) ; POINT TO DECL
301 MOVE D,(E) ; AND CURRENT VAL
310 HRRZ 0,(AB) ; LOCAL OR GLOBAL
313 MOVE B,1(AB) ; RETURN LOCATIVE IN B
316 ; MAKE OFFSET WITH SUPPLIED DECL
326 PUSHJ P,INCONS ; BUILD A LIST
329 HRR B,1(AB) ; SET UP OFFSET
332 ; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM)
333 ; JUMPS INTO PUT-DECL CODE FOR OFFSETS.
334 MFUNCTION COFFSET,SUBR,[OFFSET]
341 JRST OUTRNG ; CAN'T HAVE NEGATIVE OFFSETS
348 ; GET FIX PART OF OFFSET
359 ; Interface between EVAL and declaration processor.
360 ; E points into stack at a binding and C points to decl list.
362 CHKDCL: SKIPE IGDECL ; IGNORING DECLS?
363 POPJ P, ; YUP, JUST LEAVE
365 PUSH TP,$TTP ; SAVE BINDING
367 MOVE A,-4(E) ; GET ATOM
368 MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE
374 SETZB B,0 ; CLOBBER FOR INTGO
377 HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS
379 GETYP B,(C) ; MUST BE LIST OF ATOMS
382 MOVE B,1(C) ; GET LIST
385 CAMN A,1(B) ; SKIP IF NOT WINNER
386 JRST DCLQ ; MAY BE WINNER
387 DCL3: HRRZ B,(B) ; CDR ON
388 JUMPN B,DCL1 ; JUMP IF MORE
390 HRRZ C,(D) ; CDR MAIN LIST
391 JUMPN C,DCL2 ; AND JUMP IF WINNING
393 PUSHJ P,E.GET ; GET BINDING BACK
394 SUB TP,[2,,2] ; POP OF JUNK
397 DCLQ: GETYP C,(B) ; CHECK ATOMIC
400 PUSHJ P,E.GET ; GOT IT
401 PUSH TP,$TLIST ; SAVE PATTERN
403 MOVE B,1(D) ; GET PATTERN
405 MOVE C,-3(E) ; PROPOSED VALUE
407 PUSHJ P,TMATCH ; MATCH TYPE
410 MOVE C,-5(E) ; CHECK FOR SPEC CHANGE
411 SKIPE 0 ; MAKE SURE NON ZERO IS -1
413 SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL
425 MOVEM C,(E) ; STORE DECLS
430 TYPMI1: MOVE E,-2(TP)
434 MOVE E,-2(TP) ; GET POINTER TO BIND
435 MOVE D,-3(E) ; GET VAL
437 HRRZ C,(TP) ; DCL LIST
438 MOVE A,-4(E) ; GET ATOM
440 TYPMIS: PUSH TP,$TATOM
441 PUSH TP,EQUOTE TYPE-MISMATCH
447 JSP E,CHKARG ; HACK DEFER
450 MOVEI A,4 ; 3 ERROR ARGS
454 ERRUUO EQUOTE BAD-DECLARATION-LIST
456 ; ROUTINE TO RESSET INT STUFF
465 ; Declarations processor for MUDDLE type declarations.
466 ; Receives a pattern in a and B and an object in C and D.
467 ; It skip returns if the object fits otherwise it doesn't.
468 ; Declaration syntax errors are caught and sent to ERROR.
470 TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR
471 SKIPE IGDECL ; IGNORING DECLS?
472 JRST CPOPJ1 ; YUP, ACT LIKE THEY WON
474 TMATCX: GETYP 0,A ; GET PATTERNS TYPE
476 CAIN 0,TFORM ; MUST BE FORM OR ATOM
479 JRST TERR1 ; WRONG TYPE FOR A DCL
481 ; SIMPLE TYPE MATCHER
483 TYPMAT: GETYP E,C ; OBJECTS TYPE TO E
487 PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE
488 JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS
490 POP P,E ; RESTORE TYPE OF OBJECT
491 MOVEI 0,0 ; SPECIAL INDICATOR
492 CAIN E,(D) ; SKIP IF LOSERS
493 CPOPJ1: AOS (P) ; GOOD RETURN
496 SPECS: POP P,A ; RESTORE OBJECTS TYPE
500 JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS
501 CAMN B,IMQUOTE STRUCTURED
502 JRST ISTRUC ; LET ISTRUC DO THE WORK
503 CAMN B,IMQUOTE APPLICABLE
505 CAMN B,IMQUOTE LOCATIVE
525 ; ARRIVE HERE FOR A FORM IN THE DCLS
527 TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES
529 JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE
530 PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0
531 JRST TEXP1 ; NOT ATOM
532 CAME 0,MQUOTE SPECIAL
533 CAMN 0,MQUOTE UNSPECIAL
534 JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL
538 MOVEI 0,0 ; RET UNSPECIAL INDICATION
541 TEXP1: JUMPE B,TERR3 ; EMPTY FORM
542 GETYP E,A ; CHECK CURRENT TYPE
543 CAIN E,TATOM ; IF ATOM,
544 JRST TYPMA1 ; SIMPLE MATCH
549 GETYP 0,(B) ; WHAT IS FIRST ELEMEMT
550 CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
552 PUSH TP,$TLIST ; SAVE LIST
554 MOVE B,1(B) ; GET FORM
559 TDZA 0,0 ; REMEMBER LACK OF SKIP
564 MOVE B,(TP) ; GET BACK SAVED LIST
566 JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY
567 HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
569 ; CHECKS TYPES OF ELEMENTS OF STRUCTURES
571 ELETYP: CAIE E,TSEG ; MUST BE EXAXT?
572 JUMPE B,CPOPJ1 ; EMPTY=> WON
573 PUSH TP,$TLIST ; SAVE DCL LIST
575 MOVE A,C ; GET OBJ IN A AND B
581 PUSHJ P,TYPSGR ; GET REST/NTH CODE
583 CAIN C,5 ; BYTE STRING COMES HERE
584 JRST ELEBYT ; HACK IT
588 PUSH TP,[0] ; AND SLOTS
591 ; MAIN ELEMENT SCANNING LOOP
593 ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY
594 JRST ELETY2 ; CHEK EMPTY WINNER
597 XCT TYPG(C) ; GET ELEMENT
599 JSP E,CHKAB ; CHECK OUT DEFER
600 MOVEM A,-1(TP) ; AND SAVE IT
603 MOVE D,B ; FOR OTHER MATCHERS
604 MOVE B,-4(TP) ; GET PATTERN
606 GETYP 0,(B) ; GET TYPE OF <1 pattern>
607 MOVE B,1(B) ; GET ATOM OR WHATEVER
608 CAIE 0,TATOM ; ATOM ... SIMPLE TYPE
610 PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH
613 ; HERE TO REST EVERYTHING AND GO ON BACK
615 ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER
616 MOVE C,(P) ; GET INCREMENT CODE
618 MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR
622 ELETY9: HRRZ B,@-4(TP) ; CDR IT
626 SKIPN -1(P) ; SKIP IF EXACT REQUIRED
633 ; HERE IF PATTERN EMPTY
635 ELETY8: AOS -2(P) ; SKIP RETURN
645 ; HERE TO HANDLE EMPTY OBJECT
647 ELETY2: MOVE B,-4(TP) ; GET PATTERN
649 GETYP 0,(B) ; CHECK FOR [REST ...]
653 HLRZ 0,1(B) ; SIZE OF IT
654 CAILE 0,-4 ; MUST BE 2
657 PUSHJ P,0ATGET ; LOOK FOR REST
659 CAMN 0,MQUOTE OPTIONAL
663 JRST ELETY8 ; WINNER!!!!
666 ; HERE TO CHECK OUT A FORM ELEMNT
673 PUSHJ P,TEXP1 ; AND ANALYSE IT
675 MOVE 0,-3(TP) ; RESET DSTO
679 ; CHECK FOR VECTOR IN PATTERN
681 ELETY7: CAIE 0,TVEC ; SKIP IF WINNER
682 JRST TERR12 ; YET ANOTHER ERROR
683 HLRE C,B ; CHECK LEENGTH
684 CAMLE C,[-4] ; MUST BE 2 LONG
686 PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?
687 JRST ELET71 ; COULD BE FORM
689 CAMN 0,MQUOTE OPTIONAL
693 MOVE 0,(P) ; GET STRUC CODE
698 GETYP 0,2(B) ; SEE IF UVECTOR REST SIMPLE TYPE
702 MOVE C,3(B) ; GET ATOM
704 SUB C,0 ; POINT TO DOPE WDS
719 ELET72: MOVSI 0,(SETZ) ; FLAG USED IN RESTIT
721 PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR
725 JRST ELETY8 ; WIN AND DONE
731 ; CHECK FOR [fix .... ]
737 MOVE 0,1(B) ; GET NUMBER
738 IMULI 0,-1(C) ; COUNT MORE
740 PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS
745 ELET81: MOVE D,-2(TP) ; GET OBJECT BACK
746 MOVE 0,-3(TP) ; RESET DSTO
748 MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.
752 ; HERE TO DO A TASTEFUL TYPMAT
757 TDZA 0,0 ; REMEMBER LOSSAGE
758 MOVEI 0,1 ; OR WINNAGE
760 POP TP,C ; RESTORE OBJECT
761 JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN
764 ; HERE TO SKIP SPECIAL/UNSPECIAL
766 TMAT2: CAME 0,MQUOTE SPECIAL
769 PUSH P,0 ; SAVE INDICATOR
770 HRRZ A,(E) ; CHECK FOR EXACT LENGTH
772 GETYP A,(E) ; TYPE OF NEW PAT
781 ; LOOK FOR <OR... OR <PRIMTYPE....
785 MOVE 0,1(B) ; GET ATOM
787 JRST MQUOT ; MATCH A QUOTED OBJECT
789 CAMN 0,IMQUOTE PRIMTYPE
790 JRST ACTORT ; FALL INTO ACTOR HACKER
804 JUMPN 0,.+3 ; TO ELETYP IF WON
822 ; THIS CODE HANDLES ORs AND PRIMTYPEs
823 ACTRT1: SKIPA E,[SETZ PACT]
825 ACTORT: MOVE E,[SETZ TEXP1]
826 JUMPE B,TERR6 ; EMPTY, LOSE
827 PUSHJ P,0ATGET ; ATOM TO 0
831 HRRZ 0,(B) ; REST IT FLUSHING OR
833 PUSH TP,$TLIST ; SAVE LSIT
835 PUSH P,E ; SAVE ELEMENT CHECKER
837 ORLP: SKIPN B,(TP) ; ANY LEFT?
838 JRST ORDON ; NOPE, LOSE
839 HRRZ 0,(B) ; SAVE THE REST
841 GETYP 0,(B) ; WHAT ARE WE ORing
842 MOVE A,(B) ; TYPE WORD
843 MOVE B,1(B) ; AND ITEM
846 PUSHJ P,@(P) ; EITHER PACT OR TEXP1
852 AOS -1(P) ; SKIP RETURN FOR WINNER
854 ORDON: SUB TP,[2,,2] ; FLUSH TEMP
858 ; HERE TO PRIMTYPE ACTORS
862 JUMPE B,TERR6 ; EMPTY FORM
863 MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE
864 PACT2: CAME 0,IMQUOTE PRIMTYPE
866 HRRZ A,(B) ; GET PRIMTYPE
871 GETYP A,C ; GET OBJ TYPE
872 GETYP 0,(B) ; GET PATTERN TYPE
873 CAIE 0,TATOM ; BETTER BE ATOM
875 PUSH TP,$TLIST ; SAVE DCL LIST
879 PUSHJ P,SAT ; GET STORAGE TYPE
882 MOVE B,@STBL(A) ; GET PRIM NAME
885 MOVSI C,(D) ; FAKE OUT TYPMAT
902 CAMN B,IMQUOTE TEMPLATE
907 ; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
909 RESTIT: PUSH TP,$TVEC ; SAVE TYPE
910 ADD B,[2,,2] ; SKIP OVER CRUFT
914 RESTI1: PUSH P,A ; SAVE DISP HACK
915 PUSH P,0 ; AND COUNT HACK
916 RESTI4: SKIPL (P) ; SKIP IF DOING ALL
917 SOSL (P) ; SKIP IF DONE
920 RESTI5: SUB P,[2,,2] ; POP JUNK
928 RESTX1: MOVE C,-4(P) ; REST CODE
929 MOVE D,-6(TP) ; SET UP FOR REST
930 MOVE E,-7(TP) ; DONT FORGET DSTO
933 JRST RESTI2 ; YES, CHECK WINNAGE
935 XCT VALG(C) ; GET VAL ANDTYPE
936 JSP E,CHKAB ; CHECK DEFER
937 XCT INCR1(C) ; REST IT
938 MOVEM D,-6(TP) ; SAVE LIST
940 MOVEM E,-7(TP) ; FIXUP
944 SKIPL A,(TP) ; ANY MORE?
945 MOVE A,-2(TP) ; NO RECYCLE
947 MOVEM A,(TP) ; AND SAVE
948 MOVE B,-1(A) ; GET ELEMENT
953 MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE
955 CAIN 0,TFORM ; FORM--> HAIRY PATTERN
962 RESTI2: SKIPGE (P) ; SKIP IF WON
963 AOS -2(P) ; COUNTERACT CPOPJ1
969 ; HERE TO MATHC A QUOTED OBJ
970 ; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST
972 MQUOT: HRRZ B,(B) ; LOOK AT NEXT
974 GETYP A,(B) ; GET TYPE
976 MOVE B,1(B) ; AND VALUE
977 JSP E,CHKAB ; HACK DEFER
989 ; HERE TO HANDLE SPECIAL BYTE STRING HAIR
991 ELEBYT: MOVE B,(TP) ; GET DECL LIST BACK
992 POP P,E ; EXACTNESS FLAG
1002 LDB C,[300600,,D] ; GET BYTE SIZE
1017 ELEBY3: SETZM DSTORE
1026 CAIE 0,TATOM ; SKIP IF ATOM
1028 MOVE 0,1(B) ; GET ATOM
1031 TERR17: MOVE B,-2(TP)
1037 MOVE E,EQUOTE BAD-BYTES-DECL
1041 TERR18: SKIPA E,EQUOTE TOO-MANY-ARGS-TO-PRIMTYPE-DECL
1042 TERR16: MOVE E,EQUOTE TOO-MANY-ARGS-TO-SPECIAL-UNSPECIAL-DECL
1046 TERR9: MOVS A,0 ; TYPE TO A
1050 TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
1053 TERR2X: SUB TP,[2,,2]
1057 TERR2: MOVSI A,TATOM
1058 MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
1061 TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL
1063 TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
1066 TERR8: MOVS A,0 ; TYPE TO A
1067 MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
1069 TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
1071 TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
1073 TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
1075 TERRD: PUSH TP,$TATOM
1076 PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION