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
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 ; Change special unspecial normal mode
45 MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
51 MOVE C,SPCCHK ; GET CURRENT
52 JUMPGE AB,MODER ; RET CURRENT
53 GETYP 0,(AB) ; CHECK IT IS ATOM
58 CAMN 0,MQUOTE UNSPECIAL
68 MOVE B,MQUOTE UNSPECIAL
71 ; Function to turn special checking on and of
73 MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
92 ; Finction to set decls for GLOBAL values.
112 HRRZ D,(C) ; MAKE SURE PAIRS
113 JUMPE D,GDECLL ; LOSER, GO AWAY
118 MOVEM 0,1(TB) ; READY FOR NEXT CALL
119 MOVE C,1(C) ; SAVE ATOM LIST
125 JRST GDECL1 ; OUT OF ATOMS
126 GETYP 0,(C) ; IS THIS AN ATOM
128 JRST GDECLL ; NO, LOSE
132 PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)
133 GETYP 0,(B) ; UNBOUND?
135 JRST CHKCUR ; CHECK CURRENT VALUE
136 MOVE C,3(TB) ; GET DECL
158 TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT
159 MOVE A,-1(E) ; ATOM TO A
161 MOVE D,(E) ; GET OLD VALUE
163 JRST TYPMIS ; GO COMPLAIN
165 GDECLL: ERRUUO EQUOTE BAD-ARGUMENT-LIST
167 MFUNCTION UNMANIFEST,SUBR
174 MFUNCTION MANIFEST,SUBR
179 MANLP: JUMPGE AB,RETT
189 MFUNCTION MANIFQ,SUBR,[MANIFEST?]
198 PUSHJ P,IGLOC ; GET POINTER IF ANY
207 MFUNCTION GETDECL,SUBR,[GET-DECL]
217 HRRZ C,-2(B) ; GET GLOBAL DECL
231 GETDO1: MOVSI A,TATOM
235 RETMAN: MOVSI A,TATOM
236 MOVE B,MQUOTE MANIFEST
239 GTLOCA: HLRZ C,2(B) ; LOCAL DECL
242 MFUNCTION PUTDECL,SUBR,[PUT-DECL]
248 JRST PUTDOF ; MAKE OFFSET WITH NEW DECL
250 SKIPA E,[HRLM B,2(C)]
251 MOVE E,[HRRM B,-2(C)]
253 GETYP 0,(B) ; ANY VALUE
256 MOVE C,(B) ; GET CURRENT VALUE
262 PUTD1: MOVE C,2(AB) ; GET DECL BACK
264 PUSHJ P,INCONS ; CONS IT UP
265 MOVE C,1(AB) ; LOCATIVE BACK
271 TYPMI4: MOVE E,1(AB) ; GET LOCATIVE
272 MOVE A,-1(E) ; NOW ATOM
273 MOVEI C,2(AB) ; POINT TO DECL
274 MOVE D,(E) ; AND CURRENT VAL
283 HRRZ 0,(AB) ; LOCAL OR GLOBAL
286 MOVE B,1(AB) ; RETURN LOCATIVE IN B
289 ; MAKE OFFSET WITH SUPPLIED DECL
299 PUSHJ P,INCONS ; BUILD A LIST
302 HRR B,1(AB) ; SET UP OFFSET
305 ; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM)
306 ; JUMPS INTO PUT-DECL CODE FOR OFFSETS.
307 MFUNCTION COFFSET,SUBR,[OFFSET]
314 JRST OUTRNG ; CAN'T HAVE NEGATIVE OFFSETS
321 ; GET FIX PART OF OFFSET
332 ; Interface between EVAL and declaration processor.
333 ; E points into stack at a binding and C points to decl list.
335 CHKDCL: SKIPE IGDECL ; IGNORING DECLS?
336 POPJ P, ; YUP, JUST LEAVE
338 PUSH TP,$TTP ; SAVE BINDING
340 MOVE A,-4(E) ; GET ATOM
341 MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE
347 SETZB B,0 ; CLOBBER FOR INTGO
350 HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS
352 GETYP B,(C) ; MUST BE LIST OF ATOMS
355 MOVE B,1(C) ; GET LIST
358 CAMN A,1(B) ; SKIP IF NOT WINNER
359 JRST DCLQ ; MAY BE WINNER
360 DCL3: HRRZ B,(B) ; CDR ON
361 JUMPN B,DCL1 ; JUMP IF MORE
363 HRRZ C,(D) ; CDR MAIN LIST
364 JUMPN C,DCL2 ; AND JUMP IF WINNING
366 PUSHJ P,E.GET ; GET BINDING BACK
367 SUB TP,[2,,2] ; POP OF JUNK
370 DCLQ: GETYP C,(B) ; CHECK ATOMIC
373 PUSHJ P,E.GET ; GOT IT
374 PUSH TP,$TLIST ; SAVE PATTERN
376 MOVE B,1(D) ; GET PATTERN
378 MOVE C,-3(E) ; PROPOSED VALUE
380 PUSHJ P,TMATCH ; MATCH TYPE
383 MOVE C,-5(E) ; CHECK FOR SPEC CHANGE
384 SKIPE 0 ; MAKE SURE NON ZERO IS -1
386 SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL
398 MOVEM C,(E) ; STORE DECLS
403 TYPMI1: MOVE E,-2(TP)
407 MOVE E,-2(TP) ; GET POINTER TO BIND
408 MOVE D,-3(E) ; GET VAL
410 HRRZ C,(TP) ; DCL LIST
411 MOVE A,-4(E) ; GET ATOM
413 TYPMIS: PUSH TP,$TATOM
414 PUSH TP,EQUOTE TYPE-MISMATCH
420 JSP E,CHKARG ; HACK DEFER
423 MOVEI A,4 ; 3 ERROR ARGS
427 ERRUUO EQUOTE BAD-DECLARATION-LIST
429 ; ROUTINE TO RESSET INT STUFF
438 ; Declarations processor for MUDDLE type declarations.
439 ; Receives a pattern in a and B and an object in C and D.
440 ; It skip returns if the object fits otherwise it doesn't.
441 ; Declaration syntax errors are caught and sent to ERROR.
443 TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR
444 SKIPE IGDECL ; IGNORING DECLS?
445 JRST CPOPJ1 ; YUP, ACT LIKE THEY WON
447 TMATCX: GETYP 0,A ; GET PATTERNS TYPE
449 CAIN 0,TFORM ; MUST BE FORM OR ATOM
452 JRST TERR1 ; WRONG TYPE FOR A DCL
454 ; SIMPLE TYPE MATCHER
456 TYPMAT: GETYP E,C ; OBJECTS TYPE TO E
460 PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE
461 JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS
463 POP P,E ; RESTORE TYPE OF OBJECT
464 MOVEI 0,0 ; SPECIAL INDICATOR
465 CAIN E,(D) ; SKIP IF LOSERS
466 CPOPJ1: AOS (P) ; GOOD RETURN
469 SPECS: POP P,A ; RESTORE OBJECTS TYPE
473 JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS
474 CAMN B,IMQUOTE STRUCTURED
475 JRST ISTRUC ; LET ISTRUC DO THE WORK
476 CAMN B,IMQUOTE APPLICABLE
478 CAMN B,IMQUOTE LOCATIVE
498 ; ARRIVE HERE FOR A FORM IN THE DCLS
500 TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES
502 JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE
503 PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0
504 JRST TEXP1 ; NOT ATOM
505 CAME 0,MQUOTE SPECIAL
506 CAMN 0,MQUOTE UNSPECIAL
507 JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL
511 MOVEI 0,0 ; RET UNSPECIAL INDICATION
514 TEXP1: JUMPE B,TERR3 ; EMPTY FORM
515 GETYP E,A ; CHECK CURRENT TYPE
516 CAIN E,TATOM ; IF ATOM,
517 JRST TYPMA1 ; SIMPLE MATCH
522 GETYP 0,(B) ; WHAT IS FIRST ELEMEMT
523 CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
525 PUSH TP,$TLIST ; SAVE LIST
527 MOVE B,1(B) ; GET FORM
532 TDZA 0,0 ; REMEMBER LACK OF SKIP
537 MOVE B,(TP) ; GET BACK SAVED LIST
539 JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY
540 HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
542 ; CHECKS TYPES OF ELEMENTS OF STRUCTURES
544 ELETYP: CAIE E,TSEG ; MUST BE EXAXT?
545 JUMPE B,CPOPJ1 ; EMPTY=> WON
546 PUSH TP,$TLIST ; SAVE DCL LIST
548 MOVE A,C ; GET OBJ IN A AND B
554 PUSHJ P,TYPSGR ; GET REST/NTH CODE
556 CAIN C,5 ; BYTE STRING COMES HERE
557 JRST ELEBYT ; HACK IT
561 PUSH TP,[0] ; AND SLOTS
564 ; MAIN ELEMENT SCANNING LOOP
566 ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY
567 JRST ELETY2 ; CHEK EMPTY WINNER
570 XCT TYPG(C) ; GET ELEMENT
572 JSP E,CHKAB ; CHECK OUT DEFER
573 MOVEM A,-1(TP) ; AND SAVE IT
576 MOVE D,B ; FOR OTHER MATCHERS
577 MOVE B,-4(TP) ; GET PATTERN
579 GETYP 0,(B) ; GET TYPE OF <1 pattern>
580 MOVE B,1(B) ; GET ATOM OR WHATEVER
581 CAIE 0,TATOM ; ATOM ... SIMPLE TYPE
583 PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH
586 ; HERE TO REST EVERYTHING AND GO ON BACK
588 ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER
589 MOVE C,(P) ; GET INCREMENT CODE
591 MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR
595 ELETY9: HRRZ B,@-4(TP) ; CDR IT
599 SKIPN -1(P) ; SKIP IF EXACT REQUIRED
606 ; HERE IF PATTERN EMPTY
608 ELETY8: AOS -2(P) ; SKIP RETURN
618 ; HERE TO HANDLE EMPTY OBJECT
620 ELETY2: MOVE B,-4(TP) ; GET PATTERN
622 GETYP 0,(B) ; CHECK FOR [REST ...]
626 HLRZ 0,1(B) ; SIZE OF IT
627 CAILE 0,-4 ; MUST BE 2
630 PUSHJ P,0ATGET ; LOOK FOR REST
632 CAMN 0,MQUOTE OPTIONAL
636 JRST ELETY8 ; WINNER!!!!
639 ; HERE TO CHECK OUT A FORM ELEMNT
646 PUSHJ P,TEXP1 ; AND ANALYSE IT
648 MOVE 0,-3(TP) ; RESET DSTO
652 ; CHECK FOR VECTOR IN PATTERN
654 ELETY7: CAIE 0,TVEC ; SKIP IF WINNER
655 JRST TERR12 ; YET ANOTHER ERROR
656 HLRE C,B ; CHECK LEENGTH
657 CAMLE C,[-4] ; MUST BE 2 LONG
659 PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?
660 JRST ELET71 ; COULD BE FORM
662 CAMN 0,MQUOTE OPTIONAL
666 MOVE 0,(P) ; GET STRUC CODE
671 GETYP 0,2(B) ; SEE IF UVECTOR REST SIMPLE TYPE
675 MOVE C,3(B) ; GET ATOM
677 SUB C,0 ; POINT TO DOPE WDS
692 ELET72: MOVSI 0,(SETZ) ; FLAG USED IN RESTIT
694 PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR
698 JRST ELETY8 ; WIN AND DONE
704 ; CHECK FOR [fix .... ]
710 MOVE 0,1(B) ; GET NUMBER
711 IMULI 0,-1(C) ; COUNT MORE
713 PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS
718 ELET81: MOVE D,-2(TP) ; GET OBJECT BACK
719 MOVE 0,-3(TP) ; RESET DSTO
721 MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.
725 ; HERE TO DO A TASTEFUL TYPMAT
730 TDZA 0,0 ; REMEMBER LOSSAGE
731 MOVEI 0,1 ; OR WINNAGE
733 POP TP,C ; RESTORE OBJECT
734 JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN
737 ; HERE TO SKIP SPECIAL/UNSPECIAL
739 TMAT2: CAME 0,MQUOTE SPECIAL
742 PUSH P,0 ; SAVE INDICATOR
743 HRRZ A,(E) ; CHECK FOR EXACT LENGTH
745 GETYP A,(E) ; TYPE OF NEW PAT
754 ; LOOK FOR <OR... OR <PRIMTYPE....
758 MOVE 0,1(B) ; GET ATOM
760 JRST MQUOT ; MATCH A QUOTED OBJECT
762 CAMN 0,IMQUOTE PRIMTYPE
763 JRST ACTORT ; FALL INTO ACTOR HACKER
777 JUMPN 0,.+3 ; TO ELETYP IF WON
795 ; THIS CODE HANDLES ORs AND PRIMTYPEs
796 ACTRT1: SKIPA E,[SETZ PACT]
798 ACTORT: MOVE E,[SETZ TEXP1]
799 JUMPE B,TERR6 ; EMPTY, LOSE
800 PUSHJ P,0ATGET ; ATOM TO 0
804 HRRZ 0,(B) ; REST IT FLUSHING OR
806 PUSH TP,$TLIST ; SAVE LSIT
808 PUSH P,E ; SAVE ELEMENT CHECKER
810 ORLP: SKIPN B,(TP) ; ANY LEFT?
811 JRST ORDON ; NOPE, LOSE
812 HRRZ 0,(B) ; SAVE THE REST
814 GETYP 0,(B) ; WHAT ARE WE ORing
815 MOVE A,(B) ; TYPE WORD
816 MOVE B,1(B) ; AND ITEM
819 PUSHJ P,@(P) ; EITHER PACT OR TEXP1
825 AOS -1(P) ; SKIP RETURN FOR WINNER
827 ORDON: SUB TP,[2,,2] ; FLUSH TEMP
831 ; HERE TO PRIMTYPE ACTORS
835 JUMPE B,TERR6 ; EMPTY FORM
836 MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE
837 PACT2: CAME 0,IMQUOTE PRIMTYPE
839 HRRZ A,(B) ; GET PRIMTYPE
844 GETYP A,C ; GET OBJ TYPE
845 GETYP 0,(B) ; GET PATTERN TYPE
846 CAIE 0,TATOM ; BETTER BE ATOM
848 PUSH TP,$TLIST ; SAVE DCL LIST
852 PUSHJ P,SAT ; GET STORAGE TYPE
855 MOVE B,@STBL(A) ; GET PRIM NAME
858 MOVSI C,(D) ; FAKE OUT TYPMAT
875 CAMN B,IMQUOTE TEMPLATE
880 ; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
882 RESTIT: PUSH TP,$TVEC ; SAVE TYPE
883 ADD B,[2,,2] ; SKIP OVER CRUFT
887 RESTI1: PUSH P,A ; SAVE DISP HACK
888 PUSH P,0 ; AND COUNT HACK
889 RESTI4: SKIPL (P) ; SKIP IF DOING ALL
890 SOSL (P) ; SKIP IF DONE
893 RESTI5: SUB P,[2,,2] ; POP JUNK
901 RESTX1: MOVE C,-4(P) ; REST CODE
902 MOVE D,-6(TP) ; SET UP FOR REST
903 MOVE E,-7(TP) ; DONT FORGET DSTO
906 JRST RESTI2 ; YES, CHECK WINNAGE
908 XCT VALG(C) ; GET VAL ANDTYPE
909 JSP E,CHKAB ; CHECK DEFER
910 XCT INCR1(C) ; REST IT
911 MOVEM D,-6(TP) ; SAVE LIST
913 MOVEM E,-7(TP) ; FIXUP
917 SKIPL A,(TP) ; ANY MORE?
918 MOVE A,-2(TP) ; NO RECYCLE
920 MOVEM A,(TP) ; AND SAVE
921 MOVE B,-1(A) ; GET ELEMENT
926 MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE
928 CAIN 0,TFORM ; FORM--> HAIRY PATTERN
935 RESTI2: SKIPGE (P) ; SKIP IF WON
936 AOS -2(P) ; COUNTERACT CPOPJ1
942 ; HERE TO MATHC A QUOTED OBJ
943 ; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST
945 MQUOT: HRRZ B,(B) ; LOOK AT NEXT
947 GETYP A,(B) ; GET TYPE
949 MOVE B,1(B) ; AND VALUE
950 JSP E,CHKAB ; HACK DEFER
962 ; HERE TO HANDLE SPECIAL BYTE STRING HAIR
964 ELEBYT: MOVE B,(TP) ; GET DECL LIST BACK
965 POP P,E ; EXACTNESS FLAG
975 LDB C,[300600,,D] ; GET BYTE SIZE
999 CAIE 0,TATOM ; SKIP IF ATOM
1001 MOVE 0,1(B) ; GET ATOM
1004 TERR17: MOVE B,-2(TP)
1010 MOVE E,EQUOTE BAD-BYTES-DECL
1014 TERR18: SKIPA E,EQUOTE TOO-MANY-ARGS-TO-PRIMTYPE-DECL
1015 TERR16: MOVE E,EQUOTE TOO-MANY-ARGS-TO-SPECIAL-UNSPECIAL-DECL
1019 TERR9: MOVS A,0 ; TYPE TO A
1023 TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
1026 TERR2X: SUB TP,[2,,2]
1030 TERR2: MOVSI A,TATOM
1031 MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
1034 TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL
1036 TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
1039 TERR8: MOVS A,0 ; TYPE TO A
1040 MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
1042 TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
1044 TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
1046 TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
1048 TERRD: PUSH TP,$TATOM
1049 PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION