mirror of
https://github.com/PDP-10/its.git
synced 2026-02-18 13:37:10 +00:00
372 lines
10 KiB
Plaintext
372 lines
10 KiB
Plaintext
'<PCODE "TEMPLT">
|
||
|
||
<RPACKAGE "TEMPLATE">
|
||
|
||
<BLOCK (<ROOT>)>
|
||
|
||
OPCODE!-OP
|
||
|
||
BOOLEAN
|
||
|
||
ANY
|
||
|
||
<SETG GOING-INSANE <>>
|
||
|
||
"IF THIS FLAG IS TRUE USE MARC'S ASYLUM STUFF"
|
||
|
||
TEMPLATE-DATA
|
||
|
||
DUMP-TEMPLATE
|
||
|
||
GETTER-DATA
|
||
|
||
PUTTER-DATA
|
||
|
||
<ENDBLOCK>
|
||
|
||
<NEWTYPE LABEL WORD>
|
||
|
||
<USE-TOTAL "TEMHLP">
|
||
|
||
<SETG LOC %<RSUBR!- '[ %<PCODE!- "TEMPLT" 0> LOC #DECL ("VALUE" FIX ANY) IEMIT
|
||
EMIT CONSTANT DCLBDR MCALL PRIMTYPE-C START-CODE CONSTANT GETYP EMIT PUTIMP
|
||
TEMPLATE-SETUP COMPLR IEMIT COMPRESS NORDER ORDER XAD #FALSE ("Bad Type") TEMPLR
|
||
BOOLEAN ANY ATOM VECTOR UVECTOR WORD TEMPLATE LIST STRING
|
||
"Bad special TEMPLATE type--TEMPLATE" FIX
|
||
"Incorrect STRING specification --TEMPLATE"
|
||
"Incorrect VECTOR or UVECTOR specification--TEMPLATE"
|
||
"Incorrect LIST or WORD specification --TEMPLATE" NAME (ATOM) LAB-COUNT (FIX) (
|
||
ACTIVATION) %<RGLOC TMPLST T> #FALSE ("ALREADY A TEMPLATE") "OPTIONAL" "REST" T
|
||
%<TYPE-W OPCODE!-OP!-PACKAGE WORD> %<RGLOC GETTERS T> GETTER-DATA %<RGLOC
|
||
PUTTERS T> PUTTER-DATA TEMPLATE-DATA TAB (<LIST [REST LIST]>) FIXUP-LIST (LIST)
|
||
CODE:LIST CNT PASS1 (ANY) CODE:PTR TYPE-LIST CONSTANT-LIST TAG-LIST
|
||
DUMP-TEMPLATE %<TYPE-W LABEL WORD> INTERNAL-TEMPLATE-ERRORS!-ERRORS FLOAT FALSE
|
||
TVTOFF IENTS-LIST RVEC-LIST %<RGLOC ERRUUO T> %<TYPE-C LABEL WORD> %<TYPE-C
|
||
OPCODE!-OP!-PACKAGE WORD> BAD-CALL-TO-FIXUP!-ERRORS %<RGLOC NUMPRI T> CODE-LIST
|
||
MPOPJ TEMPLATE-TYPE-VIOLATION!-ERRORS ERROR %<RGLOC GOING-INSANE T> TABLOCK
|
||
IBLOCK RCALL FINIS RSUBR GLUE %<RGLOC MUDDLE T> REST <NOT ANY> DECL OR [REST <
|
||
NOT ANY>] "TUPLE" TUPLE]>>
|
||
<AND <ASSIGNED? GLUE> .GLUE <PUT ,LOC PGLUE ![715827882 -22548578305 -1 -1 -1
|
||
-4194304 0!]>>
|
||
|
||
|
||
<SETG SMASH %<RSUBR-ENTRY '[LOC SMASH #DECL ("VALUE" ANY ANY FIX)] 10>>
|
||
|
||
<SETG MOVIT %<RSUBR-ENTRY '[LOC MOVIT #DECL ("VALUE" FIX FIX)] 25>>
|
||
|
||
<SETG TMPLST ()>
|
||
|
||
<GDECL (TMPLST) LIST>
|
||
|
||
"OFFSETS INTO INFORMATION LIST"
|
||
|
||
<SETG TYPE-INFO 1>
|
||
|
||
<GDECL (GETTERS PUTTERS) VECTOR>
|
||
|
||
"TYPE SLOT"
|
||
|
||
<SETG LENGTH-INFO 2>
|
||
|
||
"LENGTH SLOT"
|
||
|
||
<SETG BYTE-LOC-INFO 5>
|
||
|
||
"LOCATION OF BIT START IN WORD"
|
||
|
||
<SETG FIELD-LENGTH-INFO 3>
|
||
|
||
"LENGTH OF A FIELD FOR UVEC/VEC/STRING SHORTNERS"
|
||
|
||
<SETG WORD-LOC-INFO 4>
|
||
|
||
"WORD-LOCATION OFF START IN TEMPLATE"
|
||
|
||
"OFFSETS INTO CODE-VECTOR"
|
||
|
||
<SETG 18BIT-VEC 1>
|
||
|
||
<SETG 36BIT-STRING 2>
|
||
|
||
<SETG 72BIT 3>
|
||
|
||
<SETG 36BIT 4>
|
||
|
||
<SETG 18BIT 5>
|
||
|
||
<SETG BYTE-BIT 6>
|
||
|
||
<SETG BOOLEAN-BIT 7>
|
||
|
||
<SETG 54BIT 8>
|
||
|
||
<SETG RHW <BITS 18>>
|
||
|
||
<SETG LHW <BITS 18 18>>
|
||
|
||
<SETG ERRUUO-CODE 117440512>
|
||
|
||
<MANIFEST 72BIT 36BIT 18BIT BYTE-BIT BOOLEAN-BIT RHW LHW TYPE-INFO LENGTH-INFO
|
||
FIELD-LENGTH-INFO BYTE-LOC-INFO WORD-LOC-INFO 36BIT-STRING 18BIT-VEC 54BIT
|
||
ERRUUO-CODE>
|
||
|
||
\
|
||
|
||
<SETG XAD %<RSUBR-ENTRY '[LOC XAD #DECL ("VALUE" ANY ANY)] 36>>
|
||
|
||
\
|
||
|
||
<SETG COMPRESS %<RSUBR-ENTRY '[LOC COMPRESS #DECL ("VALUE" LIST LIST)] 391>>
|
||
|
||
\
|
||
|
||
<SETG TEMPLATE %<RSUBR-ENTRY '[LOC TEMPLATE #DECL ("VALUE" ANY ATOM "TUPLE" ANY)
|
||
] 510>>
|
||
|
||
\
|
||
|
||
<SETG ORDER %<RSUBR-ENTRY '[LOC ORDER #DECL ("VALUE" <LIST FIX FIX> <LIST [REST
|
||
LIST]>)] 1100>>
|
||
|
||
\
|
||
|
||
<SETG NORDER %<RSUBR-ENTRY '[LOC NORDER #DECL ("VALUE" <LIST LIST FIX> FIX LIST)
|
||
] 1416>>
|
||
|
||
<SETG PUTIMP %<RSUBR-ENTRY '[LOC PUTIMP #DECL ("VALUE" ATOM ATOM FIX ANY)] 1647>
|
||
>
|
||
|
||
<SETG DEL %<RSUBR-ENTRY '[LOC DEL #DECL ("VALUE" STRUCTURED ATOM FIX)] 1713>>
|
||
|
||
\
|
||
|
||
<SETG COMPLR %<RSUBR-ENTRY '[LOC COMPLR #DECL ("VALUE" STRUCTURED ANY ANY ANY
|
||
ANY ANY ANY ANY)] 1754>>
|
||
|
||
<SETG FIXUP-LOCS %<RSUBR-ENTRY '[LOC FIXUP-LOCS #DECL ("VALUE" <OR FALSE LIST> <
|
||
LIST [REST <LIST [2 ANY]>]> LIST ANY)] 2044>>
|
||
|
||
<SETG BUILD-TYPE-FIXUP %<RSUBR-ENTRY '[LOC BUILD-TYPE-FIXUP #DECL ("VALUE" <LIST
|
||
[REST ANY]> LIST)] 2157>>
|
||
|
||
<SETG BUILD-TEMPLATE-CODE %<RSUBR-ENTRY '[LOC BUILD-TEMPLATE-CODE #DECL ("VALUE"
|
||
LIST VECTOR UVECTOR ANY ANY ANY)] 2237>>
|
||
|
||
"GETTER FOR 18BIT UVECTOR OR VECTOR WITH LENGTH SPECIFIED"
|
||
|
||
<SETG 18BIT-VEC-GET %<RSUBR-ENTRY '[LOC 18BIT-VEC-GET #DECL ("VALUE" <OR FIX
|
||
FLOAT> ATOM FIX FIX FIX FIX)] 2437>>
|
||
|
||
"POPJ P*"
|
||
|
||
<SETG EXIT %<RSUBR-ENTRY '[LOC EXIT #DECL ("VALUE" <OR FIX FLOAT>)] 2507>>
|
||
|
||
"SUCCESSFUL EXIT OUT OF PUTTERS"
|
||
|
||
<SETG SUCCESSFUL-EXIT %<RSUBR-ENTRY '[LOC SUCCESSFUL-EXIT #DECL ("VALUE" <OR FIX
|
||
FLOAT>)] 2520>>
|
||
|
||
"18BIT PUTTER FOR UVEC/VEC WITH LENGTH SPECIFIED"
|
||
|
||
<SETG 18BIT-VEC-PUT %<RSUBR-ENTRY '[LOC 18BIT-VEC-PUT #DECL ("VALUE" <OR FIX
|
||
FLOAT> ATOM FIX FIX FIX FIX)] 2540>>
|
||
|
||
"36BIT GETTER FOR STRING WITH LENGTH SPECIFIED"
|
||
|
||
<SETG 36BIT-STRING-GET %<RSUBR-ENTRY '[LOC 36BIT-STRING-GET #DECL ("VALUE" <OR
|
||
FIX FLOAT> ATOM FIX FIX FIX FIX)] 2626>>
|
||
|
||
"36BIT PUTTER FOR STRING WITH LENGTH SPECIFIED"
|
||
|
||
<SETG 36BIT-STRING-PUT %<RSUBR-ENTRY '[LOC 36BIT-STRING-PUT #DECL ("VALUE" <OR
|
||
FIX FLOAT> ATOM FIX FIX FIX FIX)] 2677>>
|
||
|
||
"72BIT GETTER FOR ANY. ALWAYS SKIP RETURN"
|
||
|
||
<SETG ANY-GET %<RSUBR-ENTRY '[LOC ANY-GET #DECL ("VALUE" <OR FIX FLOAT> ATOM FIX
|
||
FIX FIX FIX)] 2744>>
|
||
|
||
"72BIT PUTTER FOR ANY"
|
||
|
||
<SETG ANY-PUT %<RSUBR-ENTRY '[LOC ANY-PUT #DECL ("VALUE" <OR FIX FLOAT> ATOM FIX
|
||
FIX FIX FIX)] 2787>>
|
||
|
||
"54BIT GETTER FOR STRINGS"
|
||
|
||
<SETG 54BIT-GET %<RSUBR-ENTRY '[LOC 54BIT-GET #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 2830>>
|
||
|
||
"54BIT PUTTERS FOR STRINGS"
|
||
|
||
<SETG 54BIT-PUT %<RSUBR-ENTRY '[LOC 54BIT-PUT #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 2907>>
|
||
|
||
"36BIT-GETTER"
|
||
|
||
<SETG 36BIT-GET %<RSUBR-ENTRY '[LOC 36BIT-GET #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 3000>>
|
||
|
||
"36BIT-PUTTER"
|
||
|
||
<SETG 36BIT-PUT %<RSUBR-ENTRY '[LOC 36BIT-PUT #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 3043>>
|
||
|
||
<SETG 18BIT-GET %<RSUBR-ENTRY '[LOC 18BIT-GET #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 3093>>
|
||
|
||
<SETG 18BIT-PUT %<RSUBR-ENTRY '[LOC 18BIT-PUT #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 3170>>
|
||
|
||
<SETG BOOLEAN-GET %<RSUBR-ENTRY '[LOC BOOLEAN-GET #DECL ("VALUE" <OR FIX FLOAT>
|
||
ATOM FIX FIX FIX FIX)] 3263>>
|
||
|
||
<SETG BOOLEAN-PUT %<RSUBR-ENTRY '[LOC BOOLEAN-PUT #DECL ("VALUE" <OR FIX FLOAT>
|
||
ATOM FIX FIX FIX FIX)] 3377>>
|
||
|
||
<SETG BYTE-GET %<RSUBR-ENTRY '[LOC BYTE-GET #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 3509>>
|
||
|
||
<SETG BYTE-PUT %<RSUBR-ENTRY '[LOC BYTE-PUT #DECL ("VALUE" <OR FIX FLOAT> ATOM
|
||
FIX FIX FIX FIX)] 3563>>
|
||
|
||
<SETG EMIT-OPTIONAL %<RSUBR-ENTRY '[LOC EMIT-OPTIONAL #DECL ("VALUE" <OR FIX
|
||
FLOAT>)] 3624>>
|
||
|
||
<SETG GEN-TEMPLATE-REST %<RSUBR-ENTRY '[LOC GEN-TEMPLATE-REST #DECL ("VALUE" <OR
|
||
FALSE FIX FLOAT> UVECTOR FIX FIX FIX ANY ANY)] 3658>>
|
||
|
||
\
|
||
|
||
"ROUTINES TO ALLOW ASSEMBLY"
|
||
|
||
<SETG INTERNAL-ENTRY %<RSUBR-ENTRY '[LOC INTERNAL-ENTRY #DECL ("VALUE" <PRIMTYPE
|
||
LIST> FIX)] 3793>>
|
||
|
||
<SETG REFERENCE-R %<RSUBR-ENTRY '[LOC REFERENCE-R #DECL ("VALUE"
|
||
OPCODE!-OP!-PACKAGE ANY)] 3848>>
|
||
|
||
<SETG SPECIAL-MEMQ %<RSUBR-ENTRY '[LOC SPECIAL-MEMQ #DECL ("VALUE" <OR FALSE <
|
||
LIST ANY>> ANY LIST)] 3976>>
|
||
|
||
<SETG ERRUUO %<RSUBR-ENTRY '[LOC ERRUUO #DECL ("VALUE" <OR FIX FLOAT> ANY)] 4035
|
||
>>
|
||
|
||
<SETG GETYP %<RSUBR-ENTRY '[LOC GETYP #DECL ("VALUE" <OR FIX FLOAT> ANY "TUPLE"
|
||
ANY)] 4052>>
|
||
|
||
<SETG GEN:LABEL %<RSUBR-ENTRY '[LOC GEN:LABEL #DECL ("VALUE" LABEL)] 4079>>
|
||
|
||
<SETG PUTYP %<RSUBR-ENTRY '[LOC PUTYP #DECL ("VALUE" <OR FIX FLOAT> ANY "TUPLE"
|
||
ANY)] 4097>>
|
||
|
||
<SETG MCALL %<RSUBR-ENTRY '[LOC MCALL #DECL ("VALUE" <OR FIX FLOAT> ANY "TUPLE"
|
||
ANY)] 4124>>
|
||
|
||
<SETG EMIT %<RSUBR-ENTRY '[LOC EMIT #DECL ("VALUE" <OR FIX FLOAT> "TUPLE" ANY)]
|
||
4152>>
|
||
|
||
<SETG IEMIT %<RSUBR-ENTRY '[LOC IEMIT #DECL ("VALUE" FIX "TUPLE" ANY)] 4216>>
|
||
|
||
<SETG FIXUP %<RSUBR-ENTRY '[LOC FIXUP #DECL ("VALUE" <OR FALSE FIX> ATOM)] 4287>
|
||
>
|
||
|
||
<SETG CONSTANT %<RSUBR-ENTRY '[LOC CONSTANT #DECL ("VALUE" FIX "TUPLE" ANY)]
|
||
4421>>
|
||
|
||
<SETG TYPE-CODE %<RSUBR-ENTRY '[LOC TYPE-CODE #DECL ("VALUE" ANY ATOM)] 4528>>
|
||
|
||
<SETG LABEL:OFF %<RSUBR-ENTRY '[LOC LABEL:OFF #DECL ("VALUE" <LIST ANY ANY>
|
||
LABEL)] 4662>>
|
||
|
||
<SETG LABEL:USE %<RSUBR-ENTRY '[LOC LABEL:USE #DECL ("VALUE" LIST LABEL)] 4698>>
|
||
|
||
<SETG ADD-LABEL %<RSUBR-ENTRY '[LOC ADD-LABEL #DECL ("VALUE" <LIST ANY> LABEL)]
|
||
4738>>
|
||
|
||
<SETG FINISH-ASSEMBLY %<RSUBR-ENTRY '[LOC FINISH-ASSEMBLY #DECL ("VALUE" <OR
|
||
FALSE FIX FLOAT> ANY)] 4784>>
|
||
|
||
\
|
||
|
||
<SETG CRBDR %<RSUBR-ENTRY '[LOC CRBDR #DECL ("VALUE" ATOM ATOM UVECTOR ANY ANY
|
||
ANY ANY ANY ANY ANY)] 4839>>
|
||
|
||
<SETG GENERATE-STRUCTURE %<RSUBR-ENTRY '[LOC GENERATE-STRUCTURE #DECL ("VALUE"
|
||
ANY ANY)] 5792>>
|
||
|
||
\
|
||
|
||
<SETG START-CODE %<RSUBR-ENTRY '[LOC START-CODE #DECL ("VALUE" <OR FIX FLOAT>
|
||
ANY ANY)] 5896>>
|
||
|
||
<SETG GEN-LENGTH %<RSUBR-ENTRY '[LOC GEN-LENGTH #DECL ("VALUE" <LIST ANY ANY> <
|
||
UVECTOR [3 LIST]> ANY ANY ANY ANY ANY ANY)] 6252>>
|
||
|
||
<SETG PUT-IN-LENGTH %<RSUBR-ENTRY '[LOC PUT-IN-LENGTH #DECL ("VALUE" <OR FALSE
|
||
FIX FLOAT> <UVECTOR [3 LIST]> ANY ANY)] 6529>>
|
||
|
||
<SETG BUILD-SPEC-DECL %<RSUBR-ENTRY '[LOC BUILD-SPEC-DECL #DECL ("VALUE" <LIST [
|
||
REST ANY]> LIST)] 6673>>
|
||
|
||
<SETG FIXUP-RSUBR %<RSUBR-ENTRY '[LOC FIXUP-RSUBR #DECL ("VALUE" ANY ANY LIST
|
||
LIST LIST LIST LIST LIST LIST LIST LIST)] 6744>>
|
||
|
||
<SETG FIXUP-CODE %<RSUBR-ENTRY '[LOC FIXUP-CODE #DECL ("VALUE" <OR FALSE UVECTOR
|
||
> UVECTOR ANY)] 6950>>
|
||
|
||
<SETG FIXUP-BUILDER %<RSUBR-ENTRY '[LOC FIXUP-BUILDER #DECL ("VALUE" <LIST ANY>
|
||
LIST)] 7061>>
|
||
|
||
<SETG GLUE-BUILDER %<RSUBR-ENTRY '[LOC GLUE-BUILDER #DECL ("VALUE" UVECTOR LIST
|
||
LIST LIST UVECTOR ANY)] 7160>>
|
||
|
||
<SETG ADD-M %<RSUBR-ENTRY '[LOC ADD-M #DECL ("VALUE" <OR FALSE UVECTOR> UVECTOR
|
||
LIST)] 7282>>
|
||
|
||
<SETG PUT-IN %<RSUBR-ENTRY '[LOC PUT-IN #DECL ("VALUE" UVECTOR UVECTOR FIX FIX)]
|
||
7359>>
|
||
|
||
<SETG ADD-R %<RSUBR-ENTRY '[LOC ADD-R #DECL ("VALUE" <OR FALSE UVECTOR> ANY ANY)
|
||
] 7429>>
|
||
|
||
<SETG GEN-ARG %<RSUBR-ENTRY '[LOC GEN-ARG #DECL ("VALUE" <OR FIX FLOAT> ANY FIX
|
||
<UVECTOR [3 LIST]>)] 7512>>
|
||
|
||
<SETG OPTIONAL? %<RSUBR-ENTRY '[LOC OPTIONAL? #DECL ("VALUE" <OR ATOM FALSE> FIX
|
||
)] 7610>>
|
||
|
||
<SETG REST? %<RSUBR-ENTRY '[LOC REST? #DECL ("VALUE" <OR ATOM FALSE> FIX)] 7628>
|
||
>
|
||
|
||
<SETG EXIT? %<RSUBR-ENTRY '[LOC EXIT? #DECL ("VALUE" <OR ATOM FALSE> FIX)] 7646>
|
||
>
|
||
|
||
\
|
||
|
||
<SETG DCLBDR %<RSUBR-ENTRY '[LOC DCLBDR #DECL ("VALUE" DECL ATOM LIST LIST LIST)
|
||
] 7664>>
|
||
|
||
<SETG SQUOZE %<RSUBR-ENTRY '[LOC SQUOZE #DECL ("VALUE" WORD STRING "OPTIONAL" <
|
||
PRIMTYPE WORD>)] 8004>>
|
||
|
||
<SETG LREVERSE %<RSUBR-ENTRY '[LOC LREVERSE #DECL ("VALUE" LIST LIST)] 8101>>
|
||
|
||
<SETG GETTERS [,18BIT-VEC-GET ,36BIT-STRING-GET ,ANY-GET ,36BIT-GET ,18BIT-GET ,
|
||
BYTE-GET ,BOOLEAN-GET ,54BIT-GET]>
|
||
|
||
<SETG PUTTERS [,18BIT-VEC-PUT ,36BIT-STRING-PUT ,ANY-PUT ,36BIT-PUT ,18BIT-PUT ,
|
||
BYTE-PUT ,BOOLEAN-PUT ,54BIT-PUT]>
|
||
|
||
<SETG NUMPRI <SQUOTA <SQUOZE "NUMPRI">>>
|
||
|
||
<SETG MULTI-EMIT %<RSUBR-ENTRY '[LOC MULTI-EMIT #DECL ("VALUE" <OR FALSE FIX
|
||
FLOAT> LIST)] 8129>>
|
||
|
||
<SETG CODE-FIXUP %<RSUBR-ENTRY '[LOC CODE-FIXUP #DECL ("VALUE" LIST "TUPLE" ANY)
|
||
] 8173>>
|
||
|
||
<SETG SVALID-TYPE? %<RSUBR-ENTRY '[LOC SVALID-TYPE? #DECL ("VALUE" <OR ATOM
|
||
FALSE TYPE-C> ATOM)] 8253>>
|
||
|
||
<ENDPACKAGE>
|