/
pmem.zabstr
92 lines (91 loc) · 5.65 KB
/
pmem.zabstr
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
<FLAGS-AND-DEFAULTS (("IN-ZILCH" T)("P-DEBUGGING-PARSER" T)) ()>
<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?>
<BEGIN-SEGMENT 0>
<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)>
<CONSTANT PM-HEADER-LEN 1>
<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>
<CONSTANT PMEM-STORE-LENGTH:FIX 180>
<CONSTANT PMEM-STORE:TABLE <ITABLE ,PMEM-STORE-LENGTH>>
<GLOBAL PMEM-STORE-POINTER PMEM-STORE>
<GLOBAL PMEM-STORE-WORDS:NUMBER PMEM-STORE-LENGTH>
<GLOBAL PMEM-STORE-WARN:NUMBER 50>
<DEFINE-ROUTINE PMEM?>
<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>
<GLOBAL PMEM-WORDS-USED 0>
<GDECL (PMEM-WORDS-USED) FIX>
<DEFINE-ROUTINE PMEM-RESET>
<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>> <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-ROUTINE DO-PMEM-ALLOC>
<END-SEGMENT>
<ENDPACKAGE>