103 lines
3.0 KiB
Plaintext
103 lines
3.0 KiB
Plaintext
"(c) Copyright 1978, Massachusetts Institute of Technology. All rights reserved."
|
|
<DEFINE MSETG (FOO BAR)
|
|
#DECL ((FOO) ATOM (BAR) ANY)
|
|
<COND (<AND <GASSIGNED? .FOO> <N=? .BAR ,.FOO>>
|
|
<ERROR MSETG .FOO ALREADY-GASSIGNED ,.FOO>)
|
|
(ELSE
|
|
<SETG .FOO .BAR>
|
|
<MANIFEST .FOO>)>>
|
|
|
|
<DEFINE PSETG (FOO BAR "AUX" PL)
|
|
#DECL ((FOO) ATOM (PL) <LIST [REST ATOM]>)
|
|
<SETG .FOO .BAR>
|
|
<COND (<GASSIGNED? PURE-LIST> <SET PL ,PURE-LIST>)
|
|
(ELSE <SET PL <SETG PURE-LIST ()>>)>
|
|
<COND (<NOT <MEMQ .FOO .PL>>
|
|
<SETG PURE-LIST <SET PL (.FOO !.PL)>>)
|
|
(<AND <GASSIGNED? PURE-CAREFUL> ,PURE-CAREFUL>
|
|
<ERROR PSETG-DUPLICATE .FOO>)>
|
|
.BAR>
|
|
|
|
<DEFINE FLAGWORD ("TUPLE" FS "AUX" (TOT 1) (CNT 1))
|
|
#DECL ((FS) <TUPLE [REST <OR ATOM FALSE>]> (TOT CNT) FIX)
|
|
<MAPF <>
|
|
<FUNCTION (F)
|
|
#DECL ((F) <OR ATOM FALSE>)
|
|
<COND (<TYPE? .F ATOM>
|
|
<COND (<NOT <LOOKUP "GROUP-GLUE" <GET INITIAL OBLIST>>>
|
|
<MSETG .F .TOT>)>)>
|
|
<SET TOT <* 2 .TOT>>
|
|
<COND (<G? <SET CNT <+ .CNT 1>> 36>
|
|
<ERROR FLAGWORD .CNT>)>>
|
|
.FS>
|
|
.CNT>
|
|
|
|
<DEFINE NEWSTRUC (NAM PRIM
|
|
"ARGS" ELEM
|
|
"AUX" (LL <FORM <FORM PRIMTYPE .PRIM>>) (L .LL)
|
|
R RR (CNT 1) OFFS DEC)
|
|
#DECL ((NAM) <OR ATOM <LIST [REST ATOM]>> (PRIM) ATOM
|
|
(LL L RR R) <PRIMTYPE LIST>
|
|
(CNT) FIX (OFFS DEC) ANY (ELEM) LIST)
|
|
<REPEAT ()
|
|
<COND (<EMPTY? .ELEM>
|
|
<COND (<ASSIGNED? RR> <PUTREST .R (<VECTOR !.RR>)>)>
|
|
<COND (<TYPE? .NAM ATOM>
|
|
<COND (<LOOKUP "COMPILE" <ROOT>>
|
|
<NEWTYPE .NAM .PRIM .LL>)
|
|
(<NEWTYPE .NAM .PRIM>)>)
|
|
(ELSE
|
|
<PUT .LL 1 .PRIM>
|
|
<EVAL <FORM GDECL .NAM .LL>>
|
|
<SET NAM <1 .NAM>>)>
|
|
<RETURN .NAM>)
|
|
(<LENGTH? .ELEM 1> <ERROR NEWSTRUC>)>
|
|
<SET OFFS <1 .ELEM>>
|
|
<SET DEC <2 .ELEM>>
|
|
<COND (<OR <NOT .OFFS> <TYPE? .OFFS FORM>>
|
|
<SET CNT <+ .CNT 1>>
|
|
<SET ELEM <REST .ELEM>>
|
|
<AGAIN>)>
|
|
<COND (<AND <TYPE? .OFFS STRING> <=? .OFFS "REST">>
|
|
<AND <ASSIGNED? RR> <ERROR NEWSTRUC TWO-RESTS>>
|
|
<SET R .L>
|
|
<SET RR <SET L <LIST REST>>>
|
|
<SET ELEM <REST .ELEM>>
|
|
<AGAIN>)
|
|
(<LOOKUP "GROUP-GLUE" <GET INITIAL OBLIST>>)
|
|
(<TYPE? .OFFS ATOM>
|
|
<MSETG .OFFS .CNT>)
|
|
(<TYPE? .OFFS LIST>
|
|
<MAPF <> <FUNCTION (A) <MSETG .A .CNT>> .OFFS>)
|
|
(ELSE <ERROR NEWSTRUC>)>
|
|
<SET CNT <+ .CNT 1>>
|
|
<PUTREST .L <SET L (.DEC)>>
|
|
<SET ELEM <REST .ELEM 2>>>>
|
|
|
|
"MAKE-SLOT -- define a funny slot in an object"
|
|
|
|
<SETG SLOTS ()>
|
|
|
|
<DEFINE MAKE-SLOT (NAME 'TYP 'DEF)
|
|
#DECL ((NAME) ATOM (TYP) <OR ATOM FORM> (DEF) ANY)
|
|
<COND
|
|
(<OR <NOT <GASSIGNED? .NAME>>
|
|
<AND <ASSIGNED? REDEFINE> .REDEFINE>
|
|
<ERROR SLOT-NAME-ALREADY-USED!-ERRORS .NAME>>
|
|
<SETG SLOTS
|
|
(<EVAL <FORM DEFMAC
|
|
.NAME
|
|
'('OBJ "OPTIONAL" 'VAL)
|
|
<FORM COND
|
|
('<ASSIGNED? VAL>
|
|
<FORM FORM OPUT '.OBJ .NAME '.VAL>)
|
|
(<FORM FORM
|
|
PROG
|
|
'()
|
|
<CHTYPE ('(VALUE) .TYP) DECL>
|
|
<FORM FORM
|
|
COND
|
|
(<FORM FORM OGET '.OBJ .NAME>)
|
|
(ELSE <FORM QUOTE .DEF>)>>)>>>
|
|
!,SLOTS)>)>>
|