zorkzero/pmem.zil

"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>