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

; 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

; 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