Commit ace64f34 authored by Jesse McGrew's avatar Jesse McGrew

Converted zillib to use QQ.

parent f66b0e5c1f1d
......@@ -5,7 +5,7 @@
<NEWTYPE CLOSURE VECTOR '!<VECTOR <LIST [REST !<LIST ATOM ANY>]> FUNCTION>>
<DEFINE APPLY-CLOSURE (C:CLOSURE "ARGS" ARGS)
<EVAL <FORM BIND <1 .C> <FORM APPLY <2 .C> !.ARGS>>>>
<EVAL `<BIND ~<1 .C> <APPLY ~<2 .C> ~!.ARGS>>>>
<APPLYTYPE CLOSURE ,APPLY-CLOSURE>
......
......@@ -31,6 +31,8 @@ In the future, we may also need to store something about which part of the noun
we're trying to improve (e.g. which YSPEC is ambiguous). So we use the top bits of a word
to recall whether we're orphaning and why, and reserve the rest for future use."
<USE "QQ">
<CONSTANT P-OF-ORPHANING 32768>
<CONSTANT P-OF-MISSING 16384>
<CONSTANT P-OF-PRSI 8192>
......@@ -57,10 +59,10 @@ to recall whether we're orphaning and why, and reserve the rest for future use."
<SET V <ORB .V ,P-OF-PRSI>>)
(<N==? .WHICH PRSO>
<ERROR BAD-ARGUMENT WHICH .WHICH>)>)>
<FORM PROG '()
<FORM SETG P-O-REASON .V>
'<SETG P-V-WORDN 0>
'<SETG P-O-CONT ,P-CONT>>>
`<PROG ()
<SETG P-O-REASON ~.V>
<SETG P-V-WORDN 0>
<SETG P-O-CONT ,P-CONT>>>
<CONSTANT O-RES-NOT-HANDLED 0> ;"Not an orphaning response; parse as usual"
<CONSTANT O-RES-REORPHANED 1> ;"We asked another question; abort parse"
......
"Library header"
<USE "QQ">
<SETG ZILLIB-VERSION "J5">
<VERSION?
......@@ -23,14 +25,14 @@
<GLOBAL TRACE-INDENT 0>
<DEFMAC TRACE ('N "ARGS" A)
<FORM COND <LIST <FORM G=? ',TRACE-LEVEL .N>
'<PRINT-TRACE-INDENT>
<FORM TELL !.A>>
'(ELSE T)>>
`<COND (<G=? ,TRACE-LEVEL ~.N>
<PRINT-TRACE-INDENT>
<TELL ~!.A>)
(ELSE T)>>
<DEFMAC TRACE-DO ('N "ARGS" A)
<FORM COND <LIST <FORM G=? ',TRACE-LEVEL .N> !.A>
'(ELSE T)>>
`<COND (<G=? ,TRACE-LEVEL ~.N> ~!.A)
(ELSE T)>>
<ROUTINE PRINT-TRACE-INDENT ()
<OR ,TRACE-INDENT <RETURN>>
......@@ -91,15 +93,15 @@ other versions. These macros let us write the same code for all versions."
<VERSION?
(ZIP
<DEFMAC GET/B ('T 'O) <FORM GETB .T .O>>
<DEFMAC PUT/B ('T 'O 'V) <FORM PUTB .T .O .V>>
<DEFMAC IN-PB/WTBL? ('O 'P 'V) <FORM IN-PBTBL? .O .P .V>>
<DEFMAC IN-B/WTBL? ('T 'C 'V) <FORM IN-BTBL? .T .C .V>>)
<DEFMAC GET/B ('T 'O) `<GETB ~.T ~.O>>
<DEFMAC PUT/B ('T 'O 'V) `<PUTB ~.T ~.O ~.V>>
<DEFMAC IN-PB/WTBL? ('O 'P 'V) `<IN-PBTBL? ~.O ~.P ~.V>>
<DEFMAC IN-B/WTBL? ('T 'C 'V) `<IN-BTBL? ~.T ~.C ~.V>>)
(ELSE
<DEFMAC GET/B ('T 'O) <FORM GET .T .O>>
<DEFMAC PUT/B ('T 'O 'V) <FORM PUT .T .O .V>>
<DEFMAC IN-PB/WTBL? ('O 'P 'V) <FORM IN-PWTBL? .O .P .V>>
<DEFMAC IN-B/WTBL? ('T 'C 'V) <FORM IN-WTBL? .T .C .V>>)>
<DEFMAC GET/B ('T 'O) `<GET ~.T ~.O>>
<DEFMAC PUT/B ('T 'O 'V) `<PUT ~.T ~.O ~.V>>
<DEFMAC IN-PB/WTBL? ('O 'P 'V) `<IN-PWTBL? ~.O ~.P ~.V>>
<DEFMAC IN-B/WTBL? ('T 'C 'V) `<IN-WTBL? ~.T ~.C ~.V>>)>
"Property and flag defaults"
......@@ -183,14 +185,14 @@ other versions. These macros let us write the same code for all versions."
<GLOBAL LEXBUF KBD-LEXBUF>
<DEFMAC ACTIVATE-BUFS (PREFIX)
<FORM BIND '()
<FORM SETG READBUF <FORM GVAL <PARSE <STRING .PREFIX "-READBUF">>>>
<FORM SETG LEXBUF <FORM GVAL <PARSE <STRING .PREFIX "-LEXBUF">>>>>>
`<BIND ()
<SETG READBUF ,~<PARSE <STRING .PREFIX "-READBUF">>>
<SETG LEXBUF ,~<PARSE <STRING .PREFIX "-LEXBUF">>>>>
<DEFMAC COPY-TO-BUFS (PREFIX)
<FORM BIND '()
<FORM COPY-READBUF ',READBUF <FORM GVAL <PARSE <STRING .PREFIX "-READBUF">>>>
<FORM COPY-LEXBUF ',LEXBUF <FORM GVAL <PARSE <STRING .PREFIX "-LEXBUF">>>>>>
`<BIND ()
<COPY-READBUF ,READBUF ,~<PARSE <STRING .PREFIX "-READBUF">>>
<COPY-LEXBUF ,LEXBUF ,~<PARSE <STRING .PREFIX "-LEXBUF">>>>>
<CONSTANT P1MASK 3>
......@@ -203,21 +205,20 @@ other versions. These macros let us write the same code for all versions."
<DEFMAC VERB? ("ARGS" A "AUX" O)
<SET O <MAPF ,LIST
<FUNCTION (I)
<FORM GVAL <PARSE <STRING "V?" <SPNAME .I>>>>>
<FUNCTION (I) `,~<PARSE <STRING "V?" <SPNAME .I>>>>
.A>>
<FORM EQUAL? ',PRSA !.O>>
`<EQUAL? ,PRSA ~!.O>>
<DEFMAC PRSO? ("ARGS" A)
<FORM EQUAL? ',PRSO !.A>>
`<EQUAL? ,PRSO ~!.A>>
<DEFMAC PRSI? ("ARGS" A)
<FORM EQUAL? ',PRSI !.A>>
`<EQUAL? ,PRSI ~!.A>>
<DEFMAC WORD? ('W 'T)
<FORM CHKWORD? .W
<FORM GVAL <PARSE <STRING "PS?" <SPNAME .T>>>>
<FORM GVAL <PARSE <STRING "P1?" <SPNAME .T>>>>>>
`<CHKWORD? ~.W
,~<PARSE <STRING "PS?" <SPNAME .T>>>
,~<PARSE <STRING "P1?" <SPNAME .T>>>>>
<VERSION?
(ZIP
......@@ -315,8 +316,8 @@ Args:
<MAPF <>
<FUNCTION (FIELD)
<EVAL <FORM DEFMAC <PARSE <STRING "P-" <SPNAME .FIELD>>> '("ARGS" A)
<FORM FORM .FIELD '',P-OOPS-DATA '!.A>>>>
<EVAL `<DEFMAC ~<PARSE <STRING "P-" <SPNAME .FIELD>>> ("ARGS" A)
`<~.FIELD ,P-OOPS-DATA ~'~!.A>>>>
'(OOPS-WN OOPS-CONT OOPS-O-REASON OOPS-WINNER)>
"Structured types for storing noun phrases.
......@@ -350,19 +351,19 @@ Args:
<DEFMAC NP-YSPEC ('NP 'I)
<COND (<==? .I 1>
<FORM NP-YTBL .NP>)
`<NP-YTBL ~.NP>)
(<TYPE? .I FIX>
<FORM REST <FORM NP-YTBL .NP> <* ,P-OBJSPEC-SIZE <- .I 1>>>)
`<REST <NP-YTBL ~.NP> <* ,P-OBJSPEC-SIZE ~<- .I 1>>>)
(ELSE
<FORM REST <FORM NP-YTBL .NP> <FORM * ,P-OBJSPEC-SIZE <FORM - .I 1>>>)>>
`<REST <NP-YTBL ~.NP> <* ,P-OBJSPEC-SIZE <- ~.I 1>>>)>>
<DEFMAC NP-NSPEC ('NP 'I)
<COND (<==? .I 1>
<FORM NP-NTBL .NP>)
`<NP-NTBL ~.NP>)
(<TYPE? .I FIX>
<FORM REST <FORM NP-NTBL .NP> <* ,P-OBJSPEC-SIZE <- .I 1>>>)
`<REST <NP-NTBL ~.NP> <* ,P-OBJSPEC-SIZE ~<- .I 1>>>)
(ELSE
<FORM REST <FORM NP-NTBL .NP> <FORM * ,P-OBJSPEC-SIZE <FORM - .I 1>>>)>>
`<REST <NP-NTBL ~.NP> <* ,P-OBJSPEC-SIZE <- ~.I 1>>>)>>
<DEFSTRUCT OBJSPEC (TABLE ('NTH ZGET) ('PUT ZPUT) ('START-OFFSET 0))
(OBJSPEC-ADJ VOC)
......@@ -425,10 +426,10 @@ Args:
<VERSION?
(ZIP
<DEFMAC PRINT-ADJ ('A)
<FORM PRINT-MATCHING-WORD .A ,PS?ADJECTIVE ,P1?ADJECTIVE>>)
`<PRINT-MATCHING-WORD ~.A ,PS?ADJECTIVE ,P1?ADJECTIVE>>)
(ELSE
<DEFMAC PRINT-ADJ ('A)
<FORM TELL B .A>>)>
`<TELL B ~.A>>)>
)>
<IFFLAG (<OR DEBUG DEBUGGING-VERBS>
......@@ -470,7 +471,7 @@ Args:
<GLOBAL P-XOBJS <PRSTBL>>
<DEFMAC COPY-PRSTBL ('SRC 'DEST)
<FORM <VERSION? (ZIP COPY-TABLE-B) (ELSE COPY-TABLE)> .SRC .DEST <+ 1 ,P-MAX-OBJECTS>>>
`<~<VERSION? (ZIP COPY-TABLE-B) (ELSE COPY-TABLE)> ~.SRC ~.DEST <+ 1 ,P-MAX-OBJECTS>>>
"Structured type for backing up a complete parsed command"
<DEFSTRUCT PARSER-RESULT (TABLE ('NTH ZGET) ('PUT ZPUT) ('START-OFFSET 0))
......@@ -610,11 +611,11 @@ These extensions will be respected by other code that simulates the main loop, e
<MAIN-LOOP-END-OF-ITERATION>>>
<DEFMAC WITH-HOOK (NAME:ATOM 'EXPR "AUX" (RA ?RESULT))
<FORM BIND (.RA)
<FORM <PARSE <STRING "HOOK-BEFORE-" <SPNAME .NAME>>>>
<FORM SET .RA .EXPR>
<FORM <PARSE <STRING "HOOK-AFTER-" <SPNAME .NAME>>> .RA>
<FORM LVAL .RA>>>
`<BIND (~.RA)
<~<PARSE <STRING "HOOK-BEFORE-" <SPNAME .NAME>>>>
<SET ~.RA ~.EXPR>
<~<PARSE <STRING "HOOK-AFTER-" <SPNAME .NAME>>> ~.RA>
.~.RA>>
<DEFAULT-DEFINITION MAIN-LOOP-PARSER
<DEFMAC MAIN-LOOP-PARSER ()
......@@ -1318,12 +1319,12 @@ Returns:
(ELSE
<DEFMAC COPY-TABLE ('SRC 'DEST 'LEN "AUX" BYTES)
;"someday the compiler should do this optimization on its own..."
<COND (<TYPE? .LEN FIX> <SET BYTES <* .LEN 2>>)
(ELSE <SET BYTES <FORM * .LEN 2>>)>
<FORM COPYT .SRC .DEST .BYTES>>
<SET BYTES <COND (<TYPE? .LEN FIX> <* .LEN 2>)
(ELSE `<* ~.LEN 2>)>>
`<COPYT ~.SRC ~.DEST ~.BYTES>>
<DEFMAC COPY-TABLE-B ('SRC 'DEST 'LEN)
<FORM COPYT .SRC .DEST .LEN>>)>
`<COPYT ~.SRC ~.DEST ~.LEN>>)>
;"Determines whether a given word can start a noun phrase.
......@@ -1982,10 +1983,10 @@ Returns:
<RFALSE>>
<DEFMAC ENCODE-NOUN-BITS ('F 'O)
<FORM BOR <FORM * .F 256> .O>>
`<BOR <* ~.F 256> ~.O>>
<DEFMAC DECODE-FINDBIT ('E)
<FORM BAND <FORM / .E 256> 255>>
`<BAND </ ~.E 256> 255>>
;"Searches scope for a usable light source.
......@@ -2196,13 +2197,13 @@ Returns:
<LIST-OBJECTS .TBL <> <+ ,L-PRSTABLE ,L-THE ,L-OR>>
<TELL "?" CR>>
;"Determines whether an object is excluded by a NOUN-PHRASE's NTBL.
;"Determines whether an object is included by a NOUN-PHRASE's YTBL.
Note: NP may be evaluated twice."
<DEFMAC NP-INCLUDES? ('NP 'O)
<FORM ANY-SPEC-REFERS? <FORM NP-YTBL .NP> <FORM NP-YCNT .NP> .O>>
`<ANY-SPEC-REFERS? <NP-YTBL ~.NP> <NP-YCNT ~.NP> ~.O>>
<DEFMAC NP-INCLUDES-PSEUDO? ('NP 'PDO)
<FORM ANY-SPEC-REFERS-PSEUDO? <FORM NP-YTBL .NP> <FORM NP-YCNT .NP> .PDO>>
`<ANY-SPEC-REFERS-PSEUDO? <NP-YTBL ~.NP> <NP-YCNT ~.NP> ~.PDO>>
<ROUTINE ANY-SPEC-REFERS? (TBL N O)
<COND (<0? .N> <RFALSE>)>
......@@ -2221,10 +2222,10 @@ Returns:
;"Determines whether an object is excluded by a NOUN-PHRASE's NTBL.
Note: NP may be evaluated twice."
<DEFMAC NP-EXCLUDES? ('NP 'O)
<FORM ANY-SPEC-REFERS? <FORM NP-NTBL .NP> <FORM NP-NCNT .NP> .O>>
`<ANY-SPEC-REFERS? <NP-NTBL ~.NP> <NP-NCNT ~.NP> ~.O>>
<DEFMAC NP-EXCLUDES-PSEUDO? ('NP 'PDO)
<FORM ANY-SPEC-REFERS-PSEUDO? <FORM NP-NTBL .NP> <FORM NP-NCNT .NP> .PDO>>
`<ANY-SPEC-REFERS-PSEUDO? <NP-NTBL ~.NP> <NP-NCNT ~.NP> ~.PDO>>
;"Determines whether a local-global object is present in a given room.
......@@ -2449,38 +2450,38 @@ Example:
.GATOMS>>
<SET NEWVALUES <MAPF ,LIST 2 .TEMPS>>
<SET BINDINGS <MAPF ,LIST
<FUNCTION (T G) <LIST .T <CHTYPE .G GVAL>>>
<FUNCTION (T G) `(~.T ,~.G)>
.TEMPATOMS
.GATOMS>>
<SET SETGS <MAPF ,LIST
<FUNCTION (G V) <FORM SETG .G .V>>
<FUNCTION (G V) `<SETG ~.G ~.V>>
.GATOMS
.NEWVALUES>>
<SET RESTORES <MAPF ,LIST
<FUNCTION (G T) <FORM SETG .G <CHTYPE .T LVAL>>>
<FUNCTION (G T) `<SETG ~.G .~.T>>
.GATOMS
.TEMPATOMS>>
;"And finally..."
<FORM BIND (!.BINDINGS ?RESULT)
!.SETGS
<FORM SET ?RESULT <FORM PROG '() !.BODY>>
!.RESTORES
'.?RESULT>>
`<BIND (~!.BINDINGS ?RESULT)
~!.SETGS
<SET ?RESULT <PROG () ~!.BODY>>
~!.RESTORES
.?RESULT>>
<VERSION?
(ZIP
;"If unlit, change HERE to 'Darkness' temporarily."
<DEFMAC DO-READ ('RB 'LB)
<EXPAND <FORM WRAP-FOR-DARK-STATUS <FORM READ .RB .LB>>>>
<EXPAND `<WRAP-FOR-DARK-STATUS <READ ~.RB ~.LB>>>>
<DEFMAC WRAP-FOR-DARK-STATUS ('F)
<FORM BIND '((OHERE ,HERE))
'<COND (<NOT ,HERE-LIT> <SETG HERE ,ROOMS>)>
.F
'<SETG HERE .OHERE>>>)
`<BIND ((OHERE ,HERE))
<COND (<NOT ,HERE-LIT> <SETG HERE ,ROOMS>)>
~.F
<SETG HERE .OHERE>>>)
(ELSE
<DEFMAC DO-READ ('RB 'LB)
<FORM READ .RB .LB>>)>
`<READ ~.RB ~.LB>>)>
"Action framework"
......@@ -2771,10 +2772,10 @@ Returns:
<DEFAULT-DEFINITION RANDOM-IN-RANGE
<DEFMAC RANDOM-IN-RANGE ('LO 'HI)
<COND (<TYPE? .LO LVAL GVAL FIX FALSE CONSTANT>
<FORM - <FORM + .LO <FORM RANDOM <FORM + <FORM - .HI .LO> 1>>> 1>)
`<- <+ ~.LO <RANDOM <+ <- ~.HI ~.LO> 1>>> 1>)
(ELSE
<FORM BIND ((?LO .LO))
<FORM - <FORM + '.?LO <FORM RANDOM <FORM + <FORM - .HI '.?LO> 1>>> 1>>)>>>
`<BIND ((?LO ~.LO))
<- <+ .?LO <RANDOM <+ <- ~.HI .?LO> 1>>> 1>>)>>>
;"Returns a random element from a table, possibly repeating.
......
......@@ -8,11 +8,10 @@
(PRO-STMTS LIST)>
<DEFINE PRONOUN (NAME BINDINGS "ARGS" STMTS "AUX" CTOR-ARGS)
<SET CTOR-ARGS (''PRO-NAME .NAME
''PRO-BINDINGS .BINDINGS
''PRO-STMTS <FORM QUOTE .STMTS>)>
<SETG PRONOUN-DEFINITIONS (!,PRONOUN-DEFINITIONS
<EVAL <FORM MAKE-PRONOUN !.CTOR-ARGS>>)>>
<EVAL `<MAKE-PRONOUN 'PRO-NAME ~.NAME
'PRO-BINDINGS '~.BINDINGS
'PRO-STMTS '~.STMTS>>)>>
<DEFINE FINISH-PRONOUNS ("AUX" RTN)
<MAPF <>
......@@ -23,96 +22,90 @@
OBJS-TBL-NAME CONDITION)
;"Define table P-PRO-THEM-OBJS to hold the objects."
<SET OBJS-TBL-NAME <PARSE <STRING "P-PRO-" <SPNAME .N> "-OBJS">>>
<EVAL <FORM CONSTANT .OBJS-TBL-NAME '<ITABLE .TBLSIZE .TBLFLAGS>>>
<EVAL `<CONSTANT ~.OBJS-TBL-NAME <ITABLE .TBLSIZE .TBLFLAGS>>>
;"Define routine PRO-TRY-SET-THEM to try to set the pronoun."
<SET RTN-NAME <PARSE <STRING "PRO-TRY-SET-" <SPNAME .N>>>>
<SET CONDITION <PRO-STMTS .P>>
<COND (<LENGTH? .CONDITION 1> <SET CONDITION <1 .CONDITION>>)
(ELSE <SET CONDITION <FORM PROG '() !.CONDITION>>)>
(ELSE <SET CONDITION `<PROG () ~!.CONDITION>>)>
<SET RTN
<FORM ROUTINE .RTN-NAME
<LIST <1 <PRO-BINDINGS .P>>
PRO?OBJS
!<REST <PRO-BINDINGS .P>>>
<FORM COND
<LIST .CONDITION
<FORM
<PARSE <STRING "PRO-FORCE-SET-" <SPNAME .N>>>
'.PRO?OBJS>>>>>
`<ROUTINE ~.RTN-NAME
(~<1 <PRO-BINDINGS .P>>
PRO?OBJS
~!<REST <PRO-BINDINGS .P>>)
<COND (~.CONDITION
<~<PARSE <STRING "PRO-FORCE-SET-" <SPNAME .N>>> .PRO?OBJS>)>>>
<EVAL .RTN>
;"Define routine PRO-FORCE-SET-THEM to unconditionally set the pronoun."
<SET RTN-NAME <PARSE <STRING "PRO-FORCE-SET-" <SPNAME .N>>>>
<SET RTN
<FORM ROUTINE .RTN-NAME '(PRO?OBJS)
<FORM TRACE 4 <STRING "[setting " <SPNAME .N> " to ">>
<FORM TRACE-DO 4
<FORM LIST-OBJECTS '.PRO?OBJS <> <+ ,L-PRSTABLE ,L-THE>>
'<TELL "]" CR>>
<FORM COPY-PRSTBL
'.PRO?OBJS
<FORM GVAL .OBJS-TBL-NAME>>
'<RTRUE>>>
`<ROUTINE ~.RTN-NAME (PRO?OBJS)
<TRACE 4 "[setting " ~<SPNAME .N> " to ">
<TRACE-DO 4
<LIST-OBJECTS .PRO?OBJS <> <+ ,L-PRSTABLE ,L-THE>>
<TELL "]" CR>>
<COPY-PRSTBL .PRO?OBJS ,~.OBJS-TBL-NAME>
<RTRUE>>>
<EVAL .RTN>>>
,PRONOUN-DEFINITIONS>
;"Define SET-PRONOUNS"
<SET RTN
<FORM ROUTINE SET-PRONOUNS '(O OBJS "AUX" PT MAX)
'<COND (<=? .O <> ,ROOMS> <RFALSE>)
(<SET PT <GETPT .O ,P?PRONOUN>>
<SET MAX <- </ <PTSIZE .PT> 2> 1>>
<DO (I 0 .MAX)
<APPLY <GET .PT .I> .OBJS>>
<RTRUE>)>
!<MAPF ,LIST
<FUNCTION (P "AUX" N RTN-NAME OBJS-TBL-NAME)
<SET N <PRO-NAME .P>>
<SET RTN-NAME <PARSE <STRING "PRO-TRY-SET-" <SPNAME .N>>>>
<FORM .RTN-NAME '.O '.OBJS>>
,PRONOUN-DEFINITIONS>>>
`<ROUTINE SET-PRONOUNS (O OBJS "AUX" PT MAX)
<COND (<=? .O <> ,ROOMS> <RFALSE>)
(<SET PT <GETPT .O ,P?PRONOUN>>
<SET MAX <- </ <PTSIZE .PT> 2> 1>>
<DO (I 0 .MAX)
<APPLY <GET .PT .I> .OBJS>>
<RTRUE>)>
~!<MAPF ,LIST
<FUNCTION (P "AUX" N RTN-NAME OBJS-TBL-NAME)
<SET N <PRO-NAME .P>>
<SET RTN-NAME <PARSE <STRING "PRO-TRY-SET-" <SPNAME .N>>>>
`<~.RTN-NAME .O .OBJS>>
,PRONOUN-DEFINITIONS>>>
<EVAL .RTN>
;"Define EXPAND-PRONOUN"
<SET RTN
<FORM ROUTINE EXPAND-PRONOUN '(W OBJS "AUX" CNT)
<FORM COND
!<MAPF ,LIST
<FUNCTION (P "AUX" N OBJS-TBL-NAME)
<SET N <PRO-NAME .P>>
<SET OBJS-TBL-NAME <PARSE <STRING "P-PRO-" <SPNAME .N> "-OBJS">>>
<LIST <FORM =? '.W <VOC <SPNAME .N> OBJECT>>
<FORM COPY-PRSTBL .OBJS-TBL-NAME '.OBJS>>>
,PRONOUN-DEFINITIONS>
'(ELSE <RFALSE>)>
'<SET CNT <GETB .OBJS 0>>
'<COND (<0? .CNT>
<TELL "You haven't seen any \"" B .W "\" yet." CR>
<RETURN ,EXPAND-PRONOUN-FAILED>)>
'<COND (<NOT <STILL-VISIBLE-CHECK .OBJS>>
<RETURN ,EXPAND-PRONOUN-FAILED>)>
'<COND (<1? .CNT> <RETURN <GET/B .OBJS 1>>)
(ELSE <RETURN ,MANY-OBJECTS>)>>>
`<ROUTINE EXPAND-PRONOUN (W OBJS "AUX" CNT)
<COND
~!<MAPF ,LIST
<FUNCTION (P "AUX" N V OBJS-TBL-NAME)
<SET N <PRO-NAME .P>>
<SET V <VOC <SPNAME .N> OBJECT>>
<SET OBJS-TBL-NAME <PARSE <STRING "P-PRO-" <SPNAME .N> "-OBJS">>>
`(<=? .W ~.V> <COPY-PRSTBL ~.OBJS-TBL-NAME .OBJS>)>
,PRONOUN-DEFINITIONS>
(ELSE <RFALSE>)>
<SET CNT <GETB .OBJS 0>>
<COND (<0? .CNT>
<TELL "You haven't seen any \"" B .W "\" yet." CR>
<RETURN ,EXPAND-PRONOUN-FAILED>)>
<COND (<NOT <STILL-VISIBLE-CHECK .OBJS>>
<RETURN ,EXPAND-PRONOUN-FAILED>)>
<COND (<1? .CNT> <RETURN <GET/B .OBJS 1>>)
(ELSE <RETURN ,MANY-OBJECTS>)>>>
<EVAL .RTN>
;"Define V-PRONOUNS"
<SET RTN
<FORM ROUTINE V-PRONOUNS '()
!<MAPF ,LIST
`<ROUTINE V-PRONOUNS ()
~!<MAPF ,LIST
<FUNCTION (P "AUX" N OBJS-TBL-NAME)
<SET N <PRO-NAME .P>>
<SET OBJS-TBL-NAME <PARSE <STRING "P-PRO-" <SPNAME .N> "-OBJS">>>
<FORM PROG '()
<FORM TELL <STRING <SPNAME .N> " means ">>
<FORM LIST-OBJECTS
<FORM GVAL .OBJS-TBL-NAME>
<>
<+ ,L-PRSTABLE ,L-THE ,L-SCENERY>>
<FORM TELL "." CR>>>
<MAPRET
`<TELL ~<SPNAME .N> ,SP-MEANS-SP>
`<LIST-OBJECTS ,~.OBJS-TBL-NAME <> <+ ,L-PRSTABLE ,L-THE ,L-SCENERY>>
'<TELL "." CR>>>
,PRONOUN-DEFINITIONS>>>
<EVAL .RTN>>
<CONSTANT SP-MEANS-SP " means ">
<CONSTANT EXPAND-PRONOUN-FAILED -1>
;"Sets the appropriate pronouns to refer to an object."
......
......@@ -32,19 +32,19 @@
<CONSTANT PDO-SIZE 8>
<DEFMAC PDO-NADJ ('PDO)
<FORM GETB .PDO 0>>
`<GETB ~.PDO 0>>
<DEFMAC PDO-NNOUN ('PDO)
<FORM GETB .PDO 1>>
`<GETB ~.PDO 1>>
<DEFMAC PDO-ADJ/TBL ('PDO)
<FORM GET .PDO 1>>
`<GET ~.PDO 1>>
<DEFMAC PDO-NOUN/TBL ('PDO)
<FORM GET .PDO 2>>
`<GET ~.PDO 2>>
<DEFMAC PDO-ACTION ('PDO)
<FORM GET .PDO 3>>
`<GET ~.PDO 3>>
;"Like REFERS? but for pseudo entries.
......@@ -213,9 +213,8 @@ Returns:
<SETG NEXT-PSEUDO-AUTO-ACTION <+ .NUM 1>>
<SET NAME <PARSE <STRING "PSEUDO-AUTO-ACTION-"
<UNPARSE .NUM>>>>
<EVAL <FORM ROUTINE .NAME '()
<FORM COND <LIST <FORM VERB? !.VERBS>
<FORM PRINTR .F>>>>>
<EVAL `<ROUTINE ~.NAME ()
<COND (<VERB? ~!.VERBS> <PRINTR ~.F>)>>>
.NAME>)
(<TYPE? .F ATOM FALSE> .F)
(ELSE <ERROR BAD-PSEUDO-ACTION .F>)>>>>>
......
......@@ -22,14 +22,14 @@
,LIST
<FUNCTION (N) <PARSE <STRING <SPNAME .N> "-SCOPE-STAGE">>>
.NAMES>>
<FORM ==?
'<GET ,SCOPE-CURRENT-STAGES ,SCOPE-CURRENT-STAGE>
!.SSS>>
`<==?
<GET ,SCOPE-CURRENT-STAGES ,SCOPE-CURRENT-STAGE>
~!.SSS>>
<DEFMAC SCOPE-EXIT ('STATUS)
<FORM BIND ()
<FORM SETG MAP-SCOPE-STATUS .STATUS>
'<RETURN -1 .SCOPE-STAGE-ACTIVATION>>>
`<BIND ()
<SETG MAP-SCOPE-STATUS ~.STATUS>
<RETURN -1 .SCOPE-STAGE-ACTIVATION>>>
"Scope stages"
......@@ -73,9 +73,9 @@
<SET INIT-CODE <3 .S>>
<SET NEXT-CODE <4 .S>>
<EVAL
<FORM ROUTINE .NAME SCOPE-STAGE-ACTIVATION '(INIT)
<FORM COND <LIST '.INIT !.INIT-CODE>
<LIST ELSE !.NEXT-CODE>>>>>
`<ROUTINE ~.NAME SCOPE-STAGE-ACTIVATION (INIT)
<COND (.INIT ~!.INIT-CODE)
(ELSE ~!.NEXT-CODE)>>>>
,SCOPE-STAGES>
;"Define enough state for the most demanding stage"
......@@ -110,7 +110,7 @@
(<AND <==? <LENGTH .SV> 2> <==? <1 .SV> BITS>>
<SET STAGES <>>
<SET INIT-STAGES
<LIST <FORM MAP-SCOPE-INIT-STAGES-FROM-BITS <2 .SV>>>>)
`(<MAP-SCOPE-INIT-STAGES-FROM-BITS ~<2 .SV>>)>)
(<AND <==? <LENGTH .SV> 2> <==? <1 .SV> STAGES>>
<SET STAGES <2 .SV>>
<SET INIT-STAGES <>>)
......@@ -128,24 +128,23 @@
<MAPF ,LIST
<FUNCTION (S)
<SET I <+ .I 1>>
<FORM PUT
',SCOPE-CURRENT-STAGES
.I
<PARSE <STRING <SPNAME .S> "-SCOPE-STAGE">>>>
`<PUT
,SCOPE-CURRENT-STAGES
~.I
~<PARSE <STRING <SPNAME .S> "-SCOPE-STAGE">>>>
.STAGES>>>
<SET INIT-STAGES
<CONS <FORM PUT ',SCOPE-CURRENT-STAGES 0 <LENGTH .INIT-STAGES>>
<CONS `<PUT ,SCOPE-CURRENT-STAGES 0 ~<LENGTH .INIT-STAGES>>
.INIT-STAGES>>)>
<FORM PROG '()
!.INIT-STAGES
.INIT-OPTIONS
'<COND (<NOT <MAP-SCOPE-START>>
<RETURN>)>
<FORM REPEAT <LIST .VAR>
<FORM SET .VAR '<MAP-SCOPE-NEXT>>
<FORM COND <LIST <FORM 0? <FORM LVAL .VAR>>
'<RETURN>>>
!.BODY>>>
`<PROG ()
~!.INIT-STAGES
~.INIT-OPTIONS
<COND (<NOT <MAP-SCOPE-START>>
<RETURN>)>
<REPEAT (~.VAR)
<SET ~.VAR <MAP-SCOPE-NEXT>>
<COND (<0? .~.VAR> <RETURN>)>
~!.BODY>>>
<ROUTINE MAP-SCOPE-INIT-STAGES-FROM-BITS (BITS "AUX" (CNT 0))
;"Special case: -1 means all stages in definition order."
......@@ -154,9 +153,9 @@
%<FORM PROG '()
!<MAPF ,LIST
<FUNCTION (I "AUX" (S <1 .I>))
<FORM PUT ',SCOPE-CURRENT-STAGES
'<SET CNT <+ .CNT 1>>
<PARSE <STRING <SPNAME .S> "-SCOPE-STAGE">>>>
`<PUT ,SCOPE-CURRENT-STAGES
<SET CNT <+ .CNT 1>>
~<PARSE <STRING <SPNAME .S> "-SCOPE-STAGE">>>>
,SCOPE-STAGES>>
<RETURN>)>
;"We don't distinguish between HELD and CARRIED, or ON-GROUND and IN-ROOM."
......
......@@ -78,9 +78,9 @@ object (whether or not they're overridden!):
(ELSE .DEF)>>
<DEFINE HANDLE-DEF (NAME TYPE PROPS "AUX" F)
<SET F <FORM DEFINE .NAME '(NAME "TUPLE" PROPS "AUX" PS)
<FORM SET PS <FORM MERGE-PROPS .PROPS '.PROPS>>
<FORM .TYPE '.NAME '!.PS>>>
<SET F `<DEFINE ~.NAME (NAME "TUPLE" PROPS "AUX" PS)
<SET PS <MERGE-PROPS ~.PROPS .PROPS>>
<~.TYPE .NAME !.PS>>>
<EVAL .F>>
<DEFINE MERGE-PROPS (OLD NEW "AUX" RES A)
......
......@@ -261,7 +261,7 @@
<TELL "Not here, not now." CR>>
<DEFMAC IF-PLURAL ('O 'IF-PL 'IF-SG)
<FORM COND <LIST <FORM FSET? .O ',PLURALBIT> .IF-PL> <LIST ELSE .IF-SG>>>
`<COND (<FSET? ~.O ,PLURALBIT> ~.IF-PL) (ELSE ~.IF-SG)>>
<ROUTINE PRE-REQUIRES-LIGHT ()
<COND (<NOT ,HERE-LIT>
......@@ -422,8 +422,8 @@ Args: