271 lines
8.2 KiB
Plaintext
271 lines
8.2 KiB
Plaintext
"PMEM file for NEW PARSER
|
||
Copyright (C) 1988 Infocom, Inc. All rights reserved."
|
||
|
||
<ZZPACKAGE "PMEM">
|
||
|
||
<ENTRY PMEM PMEM-ALLOC PMEM-TYPE? PMEM-RESET PM-TYPE MAKE-PM-TYPE
|
||
PMEM-WORDS-USED PDEFS-INTERNAL-OBLIST PMEM-STORE-WARN PMEM-STORE-LENGTH>
|
||
|
||
<INCLUDE "BASEDEFS" "PBITDEFS">
|
||
|
||
<USE "NEWSTRUC">
|
||
|
||
<SET-DEFSTRUCT-FILE-DEFAULTS>
|
||
|
||
<FILE-FLAGS MDL-ZIL? ;ZAP-TO-SOURCE-DIRECTORY?>
|
||
|
||
<BEGIN-SEGMENT 0>
|
||
|
||
"All storage allocated by the parser looks like this; the rest of each
|
||
block depends on the type field."
|
||
|
||
<DEFSTRUCT PMEM (TABLE 'CONSTRUCTOR ('PRINTTYPE PRINT-PMEM)
|
||
'NODECL
|
||
('NTH ZGET)
|
||
('PUT ZPUT)
|
||
('START-OFFSET 0))
|
||
(PM-HEADER <OR FIX FALSE>)
|
||
(PM-LENGTH <OR FIX FALSE> 'OFFSET 0 'NTH GETB 'PUT PUTB)
|
||
(PM-TYPE-CODE <OR FIX FALSE> 'OFFSET 1 'NTH GETB 'PUT PUTB)>
|
||
<MSETG PM-HEADER-LEN 1>
|
||
|
||
"Only used in muddle world"
|
||
<DEFSTRUCT PM-TYPE VECTOR
|
||
(PMT-NAME ATOM)
|
||
(PMT-CODE FIX)
|
||
(PMT-LENGTH <OR FIX FALSE>)
|
||
(PMT-ARGS <VECTOR [REST PM-ARG]> [])>
|
||
|
||
<DEFSTRUCT PM-ARG VECTOR
|
||
(PMA-NAME ATOM)
|
||
(PMA-OFFS FIX)
|
||
(PMA-TYPE ANY)
|
||
(PMA-DEFAULT ANY)>
|
||
|
||
<GDECL (PM-TYPE-COUNT) FIX
|
||
(PM-LIST) LIST>
|
||
|
||
<MSETG PMEM-STORE-LENGTH:FIX 180 ;(160 125 100 300)>
|
||
<CONSTANT PMEM-STORE:TABLE <ITABLE ,PMEM-STORE-LENGTH>>
|
||
|
||
<GLOBAL PMEM-STORE-POINTER PMEM-STORE>
|
||
<GLOBAL PMEM-STORE-WORDS:NUMBER PMEM-STORE-LENGTH>
|
||
;<DEFINE-GLOBALS PMEM-GLOBALS
|
||
(PMEM-STORE-POINTER:<OR TABLE FALSE> <>)
|
||
(PMEM-STORE-WORDS:FIX ,PMEM-STORE-LENGTH)>
|
||
|
||
<IF-P-DEBUGGING-PARSER
|
||
<GLOBAL PMEM-STORE-WARN:NUMBER 50>>
|
||
|
||
<DEFINE PMEM? (PTR)
|
||
<AND <G=? .PTR ,PMEM-STORE>
|
||
<L? .PTR <+ ,PMEM-STORE ,PMEM-STORE-LENGTH>>>>
|
||
|
||
<DEFINE20 PM-TYPE (NAME:ATOM LENGTH:<OR FIX FALSE>
|
||
"ARGS" STUFF "AUX" ATM CODE TYPE-OBJ (OCT ,PM-HEADER-LEN)
|
||
ARGS)
|
||
<SET ATM <PARSE <STRING "PM-TYPE-" <SPNAME .NAME>> 10
|
||
,PDEFS-INTERNAL-OBLIST>>
|
||
<COND (<NOT <GASSIGNED? PM-TYPE-COUNT>>
|
||
<SETG PM-TYPE-COUNT 0>
|
||
<SETG PM-LIST (T)>)>
|
||
<SET CODE <SETG PM-TYPE-COUNT <+ ,PM-TYPE-COUNT 1>>>
|
||
<SET TYPE-OBJ <MAKE-PM-TYPE 'PMT-NAME .ATM
|
||
'PMT-CODE .CODE
|
||
'PMT-LENGTH .LENGTH>>
|
||
<EVAL <FORM CONSTANT
|
||
<PARSE <STRING "PMEM-TYPE-" <SPNAME .NAME>> 10
|
||
,PDEFS-INTERNAL-OBLIST>
|
||
.CODE>>
|
||
<PUTREST <REST ,PM-LIST <- <LENGTH ,PM-LIST> 1>> (.TYPE-OBJ)>
|
||
<SETG .ATM .TYPE-OBJ>
|
||
<SET ARGS
|
||
<MAPF ,VECTOR
|
||
<FUNCTION (ARG:<OR LIST ATOM> "AUX" NATM OFFS (TYPE ANY) (DEFAULT <>)
|
||
NNATM)
|
||
<COND (<TYPE? .ARG LIST>
|
||
<SET NATM <1 .ARG>>
|
||
<SET ARG <REST .ARG>>)
|
||
(T
|
||
<SET NATM .ARG>
|
||
<SET ARG ()>)>
|
||
<SET NATM <PARSE <STRING <SPNAME .NAME> "-" <SPNAME .NATM>> 10
|
||
,PDEFS-INTERNAL-OBLIST>>
|
||
<SET NNATM <PARSE <STRING <SPNAME .NAME> "-" <SPNAME .NATM> "-OFFSET">
|
||
10 ,PDEFS-INTERNAL-OBLIST>>
|
||
<EVAL <FORM DEFMAC .NATM (''OBJ "OPT" ''NEW)
|
||
<FORM COND
|
||
(<FORM ASSIGNED? NEW>
|
||
<FORM FORM ZPUT '.OBJ .OCT '.NEW>)
|
||
(T
|
||
<FORM FORM ZGET '.OBJ .OCT>)>>>
|
||
<SETG .NNATM <SET OFFS .OCT>>
|
||
<SET OCT <+ .OCT 1>>
|
||
<COND (<EMPTY? .ARG>)
|
||
(T
|
||
<SET TYPE <1 .ARG>>
|
||
<COND (<NOT <LENGTH? .ARG 1>>
|
||
<COND (<AND <TYPE? <SET DEFAULT <2 .ARG>> FORM>
|
||
<EMPTY? .DEFAULT>>
|
||
<SET DEFAULT <>>)>)>
|
||
<COND (<AND <NOT <MATCH-KEY .DEFAULT NONE>>
|
||
<NOT <TYPE? .DEFAULT FORM>>>
|
||
<COND (<NOT <DECL? .DEFAULT .TYPE>>
|
||
<COND (<DECL? .DEFAULT <FORM OR FALSE .TYPE>>
|
||
<SET TYPE <FORM OR FALSE .TYPE>>)
|
||
(T
|
||
<ERROR DEFAULT-DOESNT-MATCH-DECL
|
||
.TYPE .DEFAULT PM-TYPE>)>)>)>)>
|
||
<MAKE-PM-ARG 'PMA-NAME .NATM 'PMA-OFFS .OFFS
|
||
'PMA-TYPE .TYPE 'PMA-DEFAULT .DEFAULT>>
|
||
.STUFF>>
|
||
<PMT-ARGS .TYPE-OBJ .ARGS>>
|
||
|
||
<DEFINE20 GET-PM-TYPE (TYPE:ATOM "AUX" TEMP)
|
||
<COND (<AND <GASSIGNED? .TYPE>
|
||
<TYPE? ,.TYPE PM-TYPE>>
|
||
,.TYPE)
|
||
(T
|
||
<SET TEMP <PARSE <STRING "PM-TYPE-" <SPNAME .TYPE>> 10
|
||
,PDEFS-INTERNAL-OBLIST>>
|
||
<COND (<AND <GASSIGNED? .TEMP>
|
||
<TYPE? ,.TEMP PM-TYPE>>
|
||
,.TEMP)
|
||
(T
|
||
<ERROR NOT-A-PMEM-TYPE!-ERRORS .TYPE>)>)>>
|
||
|
||
<DEFMAC PMEM-TYPE? ('PMEM 'TYPE "OPT" 'TYPE2 "AUX" (ATM <>) (ATM2 <>))
|
||
<SET TYPE <GET-PM-TYPE .TYPE>>
|
||
<COND (<ASSIGNED? TYPE2>
|
||
<SET TYPE2 <GET-PM-TYPE .TYPE2>>)
|
||
(T
|
||
<SET TYPE2 <>>)>
|
||
<COND (<NOT .TYPE2>
|
||
<FORM ==? <FORM PM-TYPE-CODE .PMEM> <PMT-CODE .TYPE>>)
|
||
(T
|
||
<FORM OR <FORM ==? <FORM PM-TYPE .PMEM> <PMT-CODE .TYPE>>
|
||
<FORM ==? <FORM PM-TYPE .PMEM> <PMT-CODE .TYPE2>>>)>>
|
||
|
||
<DEFINE20 PRINT-PMEM (PMEM:PMEM "OPT" (OUTCHAN:CHANNEL .OUTCHAN)
|
||
"AUX" (CODE <PM-TYPE-CODE .PMEM>)
|
||
(OBJ:PM-TYPE <NTH ,PM-LIST <+ .CODE 1>>))
|
||
<PRINT-MANY .OUTCHAN PRINC "#" <PMT-NAME .OBJ> " [">
|
||
<REPEAT ((CT <PM-LENGTH .PMEM>) (N 1))
|
||
<COND (<L? <SET CT <- .CT 1>> 0>
|
||
<RETURN>)>
|
||
<PRIN1 <ZGET .PMEM .N>>
|
||
<PRINC !\ >
|
||
<SET N <+ .N 1>>>
|
||
<PRINC !\]>
|
||
.PMEM>
|
||
|
||
<SETG PMEM-WORDS-USED 0>
|
||
<GDECL (PMEM-WORDS-USED) FIX>
|
||
|
||
<DEFINE PMEM-RESET ("OPT" (FULL?:<OR ATOM FALSE> T))
|
||
<COND (<G? ,PMEM-WORDS-USED 0>
|
||
<SETG PMEM-WORDS-USED 0>
|
||
<COPYT ,PMEM-STORE 0
|
||
<* 2 <- ,PMEM-STORE-LENGTH ,PMEM-STORE-WORDS>>>)>
|
||
<SETG PMEM-STORE-WORDS ,PMEM-STORE-LENGTH>
|
||
<SETG PMEM-STORE-POINTER ,PMEM-STORE>
|
||
T>
|
||
|
||
<DEFINE20 MATCH-KEY (FOO BAR)
|
||
<AND <TYPE? .FOO ATOM>
|
||
<TYPE? .BAR ATOM>
|
||
<=? <SPNAME .FOO> <SPNAME .BAR>>>>
|
||
|
||
<DEFMAC PMEM-ALLOC PA (TYPNAM:ATOM "ARGS" STUFF "AUX" TEMP NT:PM-TYPE
|
||
BASE LENARG ATM BL)
|
||
<SET NT <GET-PM-TYPE .TYPNAM>>
|
||
<COND (<SET TEMP <MEMQ LENGTH .STUFF>>
|
||
<SET LENARG <2 .TEMP>>)
|
||
(<NOT <SET LENARG <PMT-LENGTH .NT>>>
|
||
<ERROR BAD-PMEM-LENGTH-ARG!-ERRORS .TYPNAM PMEM-ALLOC>)>
|
||
<SET BASE <FORM BIND ((NEW-OBJECT
|
||
<FORM DO-PMEM-ALLOC <PMT-CODE .NT> .LENARG>))>>
|
||
<SET BL <REST .BASE>>
|
||
<REPEAT ((ARGS <PMT-ARGS .NT>)
|
||
(INIT <CHTYPE <STACK <IVECTOR <* 2 <+ <LENGTH .ARGS>
|
||
,PM-HEADER-LEN>> NONE>>
|
||
TABLE>) THIS-ARG OFFS:FIX FRM)
|
||
<COND (<EMPTY? .STUFF>
|
||
<MAPF <>
|
||
<FUNCTION (ARG:PM-ARG "AUX" (IVAL <ZGET .INIT <PMA-OFFS .ARG>>))
|
||
<COND (<AND <MATCH-KEY .IVAL NONE>
|
||
<MATCH-KEY <PMA-DEFAULT .ARG> NONE>>
|
||
<ERROR NO-VALUE-FOR-MANDATORY-SLOT!-ERRORS .TYPNAM
|
||
PMEM-ALLOC>)
|
||
(<MATCH-KEY .IVAL NONE>
|
||
<COND
|
||
(<AND <PMA-DEFAULT .ARG>
|
||
<N==? <PMA-DEFAULT .ARG> '<>>
|
||
<N==? <PMA-DEFAULT .ARG> 0>>
|
||
;"PMEM-RESET zeroes memory, so if something is going
|
||
to be defaulted to 0 or false, don't bother."
|
||
<SET BL <REST
|
||
<PUTREST .BL
|
||
(<FORM <PMA-NAME .ARG>
|
||
'.NEW-OBJECT
|
||
<PMA-DEFAULT .ARG>>)>>>)>)>>
|
||
.ARGS>
|
||
<RETURN>)>
|
||
<COND (<OR <NOT <TYPE? <SET ATM <1 .STUFF>> ATOM>>
|
||
<AND <OR <NOT <GASSIGNED? .ATM>>
|
||
<NOT <TYPE? ,.ATM FIX MACRO>>>
|
||
<SET ATM <PARSE <STRING <SPNAME .TYPNAM> "-" <SPNAME .ATM>>
|
||
10 ,PDEFS-INTERNAL-OBLIST>>
|
||
<OR <NOT <GASSIGNED? .ATM>>
|
||
<NOT <TYPE? ,.ATM FIX MACRO>>>>>
|
||
<COND (<N==? <1 .STUFF> LENGTH>
|
||
<ERROR BAD-PMEM-ARG!-ERRORS .STUFF PMEM-ALLOC>)>)
|
||
(T
|
||
<SET FRM <EXPAND <FORM .ATM .INIT T>>>
|
||
<ZPUT .INIT <3 .FRM:FORM> T>
|
||
<COND (<AND <2 .STUFF>
|
||
<N==? <2 .STUFF> '<>>
|
||
<N==? <2 .STUFF> 0>>
|
||
<SET BL <REST <PUTREST .BL
|
||
(<FORM .ATM '.NEW-OBJECT <2 .STUFF>>)>>>)>)>
|
||
<SET STUFF <REST .STUFF 2>>>
|
||
<PUTREST .BL ('.NEW-OBJECT)>
|
||
.BASE>
|
||
|
||
<DEFINE DO-PMEM-ALLOC PA (TYPE:FIX LENGTH:FIX
|
||
"AUX" (STOR ,PMEM-STORE-POINTER)
|
||
(LEFT:FIX ,PMEM-STORE-WORDS) NEW)
|
||
;<COND (<NOT .STOR>
|
||
<SET STOR ,PMEM-STORE>)>
|
||
<SET LENGTH <+ .LENGTH 1>> ;"in words"
|
||
<DEBUG-CHECK <G? .LENGTH .LEFT>
|
||
<COND (<ERROR OUT-OF-MEMORY!-ERRORS
|
||
ERRET-T-TO-ALLOCATE-MORE!-ERRORS
|
||
PMEM-ALLOC>
|
||
<SETG PMEM-STORE-WORDS 500>
|
||
<SET LEFT 500>
|
||
<PMEM-STORE-LENGTH <+ <PMEM-STORE-LENGTH> 500>>
|
||
<PMEM-STORE <SET STOR <ITABLE <PMEM-STORE-LENGTH> 0>>>)
|
||
(T
|
||
<RETURN <> .PA>)>>
|
||
<COND (<G? .LENGTH .LEFT>
|
||
<P-NO-MEM-ROUTINE .TYPE>
|
||
;<RETURN <> .PA>)>
|
||
<SETG PMEM-WORDS-USED <+ ,PMEM-WORDS-USED .LENGTH>>
|
||
<SETG PMEM-STORE-WORDS <- .LEFT .LENGTH>>
|
||
<IF-P-DEBUGGING-PARSER
|
||
<COND (<G? ,PMEM-STORE-WARN ,PMEM-STORE-WORDS>
|
||
<SETG PMEM-STORE-WARN ,PMEM-STORE-WORDS>
|
||
<PRINTI "[Debugging info: ">
|
||
<PRINTI "PMEM: ">
|
||
<PRINTN ,PMEM-STORE-WARN ;,PMEM-STORE-WORDS>
|
||
<PRINTI " left!]|">)>>
|
||
<SETG PMEM-STORE-POINTER <ZREST .STOR <* .LENGTH 2>>>
|
||
<PM-LENGTH <CHTYPE-VAL STOR PMEM>
|
||
<SET LENGTH <- .LENGTH 1>>>
|
||
<PM-TYPE-CODE .STOR .TYPE>
|
||
.STOR>
|
||
|
||
<END-SEGMENT>
|
||
<ENDPACKAGE>
|