--- /dev/null
+
+<PACKAGE "PARSE-DEFINITIONS">
+
+"Definitions of types and offsets appropriate for trees built by ADAPLEX
+ parser"
+
+<ENTRY PRETTY
+ NOT-PRETTY
+ USETYPE
+ FOR-LOOP
+ ITERATOR
+ FOR-BODY
+ ITERATION
+ LOOP-CONTROL
+ LOOP-IDENTIFIER
+ LOOP-SET-EXPRESSION
+ LOOP-PREDICATE
+ LOOP-ORDER
+ LOOP-ORDER-FUNCTION
+ RETRIEVE
+ RETRIEVE-SET
+ RETRIEVE-WORKSPACE
+ RETRIEVE-TARGET-LIST
+ PRINTYPE
+ IFTYPE
+ CLAUSE
+ CLAUSE-PREDICATE
+ CLAUSE-LIST-OF-COMMANDS
+ SETTYPE
+ FCN
+ FCN-NAME
+ FCN-ARGUMENT
+ RESTRICTION
+ RESTRICT-ID
+ RESTRICT-SET
+ RESTRICT-PRED
+ OPERATOR
+ OP-NAME
+ OP-OP1
+ OP-OP2
+ QUANTIFIER
+ QUANT-TYPE
+ QUANT-NUM
+ QUANT-ID
+ QUANT-SET
+ QUANT-PRED
+ QUANT-TEST
+ EXISTS
+ EXISTS-TYPE
+ EXISTS-SET
+ AGGREGATE
+ AGG-NAME
+ AGG-FCN
+ AGG-SET
+ AGG-OVER
+ IDENTIFIER
+ ID-NAME
+ ID-TYPE
+ ID-OTHER
+ VIRTUAL
+ ENTITY-DEF-EXTENT
+ ENTITY-DEF-VIRTUAL?
+ SUPERTYPE
+ COTYPE
+ FCN-DFN
+ FCN-DFN-NAME
+ FCN-DFN-FORMAT
+ EXTENT
+ EXTENT-NAME
+ EXTENT-EMAP
+ EXTENT-FMAP
+ JOIN
+ PROJECT
+ PROJECT-MAPLIST
+ PROJECT-FCNLIST
+ FCNMAP
+ FCNMAP-NAME
+ FCNMAP-SETEXP
+ ENTITY-DEF
+ ENTITY-DEF-NAME
+ ENTITY-DEF-FCN-LIST
+ ENTITY-DEF-SUPERTYPES
+ ENTITY-DEF-COTYPES>
+
+"\f"
+
+"Define MSETG to SETG an atom and make it manifest as well"
+
+<DEFINE MSETG (ATOM VAL) <SETG .ATOM .VAL> <MANIFEST .ATOM>>
+
+
+"INDENTATION and INDENT-AMT are used in pretty printing of ADAPLEX"
+
+<SET INDENTATION 0>
+
+<MSETG INDENT-AMT 8>
+
+"Define type for USE statement"
+
+<NEWTYPE USETYPE LIST>
+
+<DEFINE P-USETYPE (L) <IPRINC "USE ">
+ <PRINT-LIST .L>
+ <PRINC !\;>>
+
+<NEWTYPE FOR-LOOP VECTOR '<<PRIMTYPE VECTOR> ITERATION LIST>>
+
+"FOR loops have iteration spec and a list of commands"
+
+<MSETG ITERATOR <OFFSET 1 FOR-LOOP>>
+
+<MSETG FOR-BODY <OFFSET 2 FOR-LOOP>>
+
+"Function to print for loops nicely"
+
+<DEFINE PRINT-FOR (FL)
+ #DECL ((FL) FOR-LOOP)
+ <IPRINT <ITERATOR .FL>>
+ <CRLF>
+ <SET INDENTATION <+ .INDENTATION ,INDENT-AMT>>
+ <PRINT-SEQ <FOR-BODY .FL>>
+ <IPRINC "END;">
+ <SET INDENTATION <- .INDENTATION ,INDENT-AMT>>>
+
+"\f"
+"Type ITERATION specifies the range of a for loop."
+
+<NEWTYPE ITERATION
+ VECTOR
+ '<<PRIMTYPE VECTOR> <OR FALSE FIX>
+ IDENTIFIER
+ ANY
+ ANY
+ ATOM
+ <OR IDENTIFIER FALSE>>>
+
+<MSETG LOOP-CONTROL <OFFSET 1 ITERATION>>
+
+<MSETG LOOP-IDENTIFIER <OFFSET 2 ITERATION>>
+
+<MSETG LOOP-SET-EXPRESSION <OFFSET 3 ITERATION>>
+
+<MSETG LOOP-PREDICATE <OFFSET 4 ITERATION>>
+
+<MSETG LOOP-ORDER <OFFSET 5 ITERATION>>
+
+<MSETG LOOP-ORDER-FUNCTION <OFFSET 6 ITERATION>>
+
+
+
+<DEFINE ITERATOR-PRINT (ITER)
+ #DECL ((ITER) ITERATION)
+ <IPRINC "FOR ">
+ <COND (<LOOP-CONTROL .ITER>
+ <PRINC "UP TO ">
+ <PRIN1 <LOOP-CONTROL .ITER>>)
+ (ELSE <PRINC "EACH">)>
+ <PRINC " ">
+ <PRIN1 <LOOP-IDENTIFIER .ITER>>
+ <PRINC " IN ">
+ <PRIN1 <LOOP-SET-EXPRESSION .ITER>>
+ <COND (<LOOP-PREDICATE .ITER>
+ <PRINC " WHERE ">
+ <PRIN1 <LOOP-PREDICATE .ITER>>)>
+ <COND (<N==? <LOOP-ORDER .ITER> RANDOM>
+ <PRINC " IN ">
+ <PRIN1 <LOOP-ORDER .ITER>>
+ <PRINC " BY ">
+ <PRIN1 <LOOP-ORDER-FUNCTION .ITER>>)>>
+
+"Type RETRIEVE is produced by a Retrieve statement in the language"
+
+<NEWTYPE RETRIEVE VECTOR '<<PRIMTYPE VECTOR> ANY IDENTIFIER LIST>>
+
+<MSETG RETRIEVE-SET <OFFSET 1 RETRIEVE>>
+
+<MSETG RETRIEVE-WORKSPACE <OFFSET 2 RETRIEVE>>
+
+<MSETG RETRIEVE-TARGET-LIST <OFFSET 3 RETRIEVE>>
+
+<DEFINE PRINT-RETRIEVE (RETRV) #DECL ((RETRV) RETRIEVE)
+ <IPRINC "RETRIEVE ">
+ <PRIN1 <RETRIEVE-SET .RETRV>>
+ <PRINC " INTO ">
+ <PRIN1 <RETRIEVE-WORKSPACE .RETRV>>
+ <PRINC " ">
+ <PRINT-LIST <RETRIEVE-TARGET-LIST .RETRV>>
+ <PRINC ";">>
+
+"\f"
+"Type PRINTYPE is produced for a PRINT command"
+
+<NEWTYPE PRINTYPE LIST>
+
+<DEFINE PRINT-PRINT (L)
+ <IPRINC "PRINT ">
+ <PRINT-LIST .L>>
+
+"Various kinds of IFs become IFTYPE. IFTYPE is a list of CLAUSEs. Each
+ clause has a predicate and a list of things to do on truth."
+
+<NEWTYPE IFTYPE LIST>
+
+<DEFINE IFTYPE-PRINT (L "AUX" (FIRST T))
+ #DECL ((L) IFTYPE)
+ <MAPF <>
+ <FUNCTION (C)
+ #DECL ((C) CLAUSE)
+ <COND (<==? <CLAUSE-PREDICATE .C> ELSE> <IPRINC "ELSE ">)
+ (ELSE
+ <COND (.FIRST <IPRINC "IF ">)
+ (ELSE <IPRINC "ELSEIF ">)>
+ <PRIN1 <CLAUSE-PREDICATE .C>>
+ <PRINC " THEN ">)>
+ <CRLF>
+ <SET INDENTATION <+ .INDENTATION ,INDENT-AMT>>
+ <PRINT-SEQ <CLAUSE-LIST-OF-COMMANDS .C>>
+ <SET INDENTATION <- .INDENTATION ,INDENT-AMT>>
+ <SET FIRST <>>>
+ .L>
+ <IPRINC "END IF">>
+
+<NEWTYPE CLAUSE VECTOR '<<PRIMTYPE VECTOR> ANY LIST>>
+
+<MSETG CLAUSE-PREDICATE <OFFSET 1 CLAUSE>>
+
+<MSETG CLAUSE-LIST-OF-COMMANDS <OFFSET 2 CLAUSE>>
+
+"\f"
+
+"Explicit sets become lists of the explicit objects in the set"
+
+<NEWTYPE SETTYPE LIST>
+
+<DEFINE SET-PRINT (L) <PRINT-LIST .L>>
+
+"Type FCN is for entity function calls"
+
+<NEWTYPE FCN VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY>>
+
+<MSETG FCN-NAME <OFFSET 1 FCN>>
+
+<MSETG FCN-ARGUMENT <OFFSET 2 FCN>>
+
+<DEFINE FCN-PRINT (FC) #DECL ((FC) FCN)
+ <PRIN1 <FCN-NAME .FC>>
+ <PRINC " (">
+ <PRIN1 <FCN-ARGUMENT .FC>>
+ <PRINC ")">>
+
+"Type RESTRICTION is for restricted sets. It has a variable, an input set and
+ a predicate"
+
+<NEWTYPE RESTRICTION VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY ANY>>
+
+<MSETG RESTRICT-ID <OFFSET 1 RESTRICTION>>
+
+<MSETG RESTRICT-SET <OFFSET 2 RESTRICTION>>
+
+<MSETG RESTRICT-PRED <OFFSET 3 RESTRICTION>>
+
+<DEFINE RESTRICT-PRINT (RES) #DECL ((RES) RESTRICTION)
+ <PRINC "(">
+ <PRIN1 <RESTRICT-ID .RES>>
+ <PRINC " IN ">
+ <PRIN1 <RESTRICT-SET .RES>>
+ <PRINC " WHERE ">
+ <PRIN1 <RESTRICT-PRED .RES>>
+ <PRINC ")">>
+"\f"
+"Type OPERATOR is for +,- etc."
+
+<NEWTYPE OPERATOR VECTOR '<<PRIMTYPE VECTOR> ATOM ANY ANY>>
+
+<MSETG OP-NAME <OFFSET 1 OPERATOR>>
+
+<MSETG OP-OP1 <OFFSET 2 OPERATOR>>
+
+<MSETG OP-OP2 <OFFSET 3 OPERATOR>>
+
+<DEFINE OP-PRINT (OP) #DECL ((OP) OPERATOR)
+ <COND (<OP-OP2 .OP> ;"Binary operator"
+ <COND (<TYPE? <OP-OP1 .OP> OPERATOR>
+ <PRINC "(">)>
+ <PRIN1 <OP-OP1 .OP>>
+ <COND (<TYPE? <OP-OP1 .OP> OPERATOR>
+ <PRINC ")">)>
+ <COND (<L=? <LENGTH <SPNAME <OP-NAME .OP>>> 2>
+ <PRINC <OP-NAME .OP>>)
+ (ELSE
+ <PRINC " ">
+ <PRINC <OP-NAME .OP>>
+ <PRINC " ">)>
+ <COND (<TYPE? <OP-OP2 .OP> OPERATOR>
+ <PRINC "(">)>
+ <PRIN1 <OP-OP2 .OP>>
+ <COND (<TYPE? <OP-OP2 .OP> OPERATOR>
+ <PRINC ")">)>)
+ (ELSE
+ <COND (<L=? <LENGTH <SPNAME <OP-NAME .OP>>> 2>
+ <PRINC <OP-NAME .OP>>)
+ (ELSE
+ <PRINC <OP-NAME .OP>>
+ <PRINC " ">)>
+ <PRIN1 <OP-OP1 .OP>>)>>
+
+"\f"
+"Type QUANTIFIER is for DAPLEX quantifiers FOR SOME etc."
+
+<NEWTYPE QUANTIFIER
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM FIX IDENTIFIER ANY ANY ANY>>
+
+<MSETG QUANT-TYPE <OFFSET 1 QUANTIFIER>>
+
+<MSETG QUANT-NUM <OFFSET 2 QUANTIFIER>>
+
+<MSETG QUANT-ID <OFFSET 3 QUANTIFIER>>
+
+<MSETG QUANT-SET <OFFSET 4 QUANTIFIER>>
+
+<MSETG QUANT-PRED <OFFSET 5 QUANTIFIER>>
+
+<MSETG QUANT-TEST <OFFSET 6 QUANTIFIER>>
+
+<DEFINE QUANT-PRINT (Q)
+ #DECL ((Q) QUANTIFIER)
+ <PRINC "FOR ">
+ <COND (<0? <QUANT-NUM .Q>> <PRIN1 <QUANT-TYPE .Q>>)
+ (ELSE
+ <PRINC <COND (<==? <QUANT-TYPE .Q> AT-LEAST> "AT LEAST ")
+ (ELSE "AT MOST ")>>
+ <PRIN1 <QUANT-NUM .Q>>)>
+ <PRINC " ">
+ <PRIN1 <QUANT-ID .Q>>
+ <PRINC " IN ">
+ <PRIN1 <QUANT-SET .Q>>
+ <COND (<QUANT-PRED .Q> <PRINC " WHERE "> <PRIN1 <QUANT-PRED .Q>>)>
+ <PRINC " TEST ">
+ <PRIN1 <QUANT-TEST .Q>>>
+
+<NEWTYPE EXISTS VECTOR '<<PRIMTYPE VECTOR> ATOM FIX ANY>>
+
+<MSETG EXISTS-TYPE <OFFSET 1 EXISTS>>
+
+<MSETG EXISTS-NUM <OFFSET 2 EXISTS>>
+
+<MSETG EXISTS-SET <OFFSET 3 EXISTS>>
+
+<NEWTYPE AGGREGATE
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM <OR IDENTIFIER FALSE> ANY <OR FALSE ATOM>>>
+
+<MSETG AGG-NAME <OFFSET 1 AGGREGATE>>
+
+<MSETG AGG-FCN <OFFSET 2 AGGREGATE>>
+
+<MSETG AGG-SET <OFFSET 3 AGGREGATE>>
+
+<MSETG AGG-OVER <OFFSET 4 AGGREGATE>>
+
+<NEWTYPE IDENTIFIER VECTOR '<<PRIMTYPE VECTOR> ATOM ANY ANY>>
+
+<MSETG ID-NAME <OFFSET 1 IDENTIFIER>>
+
+<MSETG ID-TYPE <OFFSET 1 IDENTIFIER>>
+
+<MSETG ID-OTHER <OFFSET 1 IDENTIFIER>>
+
+<DEFINE PRINT-ID (ID) #DECL ((ID) IDENTIFIER) <PRIN1 <ID-NAME .ID>>>
+
+<NEWTYPE SUPERTYPE LIST>
+
+<NEWTYPE COTYPE LIST>
+
+<NEWTYPE FCN-DFN VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY>>
+
+<MSETG FCN-DFN-NAME <OFFSET 1 FCN-DFN>>
+
+<MSETG FCN-DFN-FORMAT <OFFSET 2 FCN-DFN>>
+
+<NEWTYPE EXTENT
+ VECTOR
+ '<<PRIMTYPE VECTOR> IDENTIFIER
+ <OR JOIN RESTRICTION PROJECT>
+ <LIST [REST FCNMAP]>>>
+
+<MSETG EXTENT-NAME <OFFSET 1 EXTENT>>
+
+<MSETG EXTENT-EMAP <OFFSET 2 EXTENT>>
+
+<MSETG EXTENT-FMAP <OFFSET 3 EXTENT>>
+
+<NEWTYPE JOIN LIST>
+
+<NEWTYPE PROJECT VECTOR '<<PRIMTYPE VECTOR> LIST LIST>>
+
+<MSETG PROJECT-MAPLIST <OFFSET 1 PROJECT>>
+
+<MSETG PROJECT-FCNLIST <OFFSET 2 PROJECT>>
+
+<NEWTYPE FCNMAP VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY>>
+
+<MSETG FCNMAP-NAME <OFFSET 1 FCNMAP>>
+
+<MSETG FCNMAP-SETEXP <OFFSET 2 FCNMAP>>
+
+<NEWTYPE ENTITY-DEF
+ VECTOR
+ '<<PRIMTYPE VECTOR> IDENTIFIER
+ LIST
+ <OR FALSE <LIST ANY>>
+ <OR FALSE <LIST ANY>>
+ <OR FALSE ATOM>
+ <OR EXTENT FALSE>>>
+
+<MSETG ENTITY-DEF-NAME <OFFSET 1 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-FCN-LIST <OFFSET 2 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-SUPERTYPES <OFFSET 3 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-COTYPES <OFFSET 4 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-VIRTUAL? <OFFSET 5 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-EXTENT <OFFSET 6 ENTITY-DEF>>
+
+
+"Utility print stuff"
+
+<DEFINE PRINT-LIST (L) #DECL ((L) <PRIMTYPE LIST>)
+ <PRINC "(">
+ <MAPR <>
+ <FUNCTION (LL "AUX" (X <1 .LL>))
+ <PRIN1 .X>
+ <COND (<EMPTY? <REST .LL>> <PRINC ")">)
+ (ELSE <PRINC ", ">)>>
+ .L>>
+
+<DEFINE PRINT-SEQ (L) #DECL ((L) <PRIMTYPE LIST>)
+ <MAPF <>
+ <FUNCTION (X)
+ <IPRINT .X>
+ <PRINC ";">
+ <CRLF>> .L>>
+
+<DEFINE IPRINT (OBJ)
+ <INDENT-TO .INDENTATION>
+ <PRIN1 .OBJ>>
+
+<DEFINE IPRINC (OBJ)
+ <INDENT-TO .INDENTATION>
+ <PRINC .OBJ>>
+
+
+
+<DEFINE PRETTY ()
+ <MAPF <> <FUNCTION (TYPE FCN) <PRINTTYPE .TYPE .FCN>> ,TYPES ,PSUBRS>>
+
+<DEFINE NOT-PRETTY ()
+ <MAPF <> <FUNCTION (TYPE) <PRINTTYPE .TYPE ,PRINT>> ,TYPES>>
+
+<SETG TYPES
+ '![USETYPE
+ FOR-LOOP
+ ITERATION
+ RETRIEVE
+ PRINTYPE
+ IFTYPE
+ SETTYPE
+ FCN
+ RESTRICTION
+ OPERATOR
+ QUANTIFIER
+ IDENTIFIER!]>
+
+<SETG PSUBRS
+ [,P-USETYPE
+ ,PRINT-FOR
+ ,ITERATOR-PRINT
+ ,PRINT-RETRIEVE
+ ,PRINT-PRINT
+ ,IFTYPE-PRINT
+ ,SET-PRINT
+ ,FCN-PRINT
+ ,RESTRICT-PRINT
+ ,OP-PRINT
+ ,QUANT-PRINT
+ ,PRINT-ID]>
+
+<ENDPACKAGE>
+\0
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff