Fixed systematic errors in the original MDL documentation scans (starting around...
[pdp10-muddle.git] / mim / development / mim / vax / mimlib / backquote.mud
1 <PACKAGE "BACKQUOTE">
2
3 ;"NOTE: This pakcage can only be used compiled.
4
5   Loading BACKQUOTE causes subsequent READs to interpret backquote as a 
6   special character.  Backquote quotes the following object EXCEPT for objects
7   within it that are preceeded by a tilde.  Thus
8
9         `<+ ~.A .INC>
10
11   is equivalent to
12
13         <CHTYPE (+ .A '.INC) FORM>
14
15   This is most useful in defining MACROs, although it can be used anywhere a
16   program needs to construct a large object, most of which is constant.  Note
17   that BACKQUOTE makes no guarantees about ==?-ness of the objects it creates,
18   so no PUTs or PUTRESTs should be done on them.
19
20   Backquotes can be nested--they can be used to define macros that define 
21   macros.  Tilde is not treated as a special character unless it is inside a
22   backquoted object."
23
24 <NEWTYPE TILDE LIST '<<PRIMTYPE LIST> ANY>>
25
26 <DEFINE TILDE-READ-MACRO (CHAN CHAR) 
27    <CHTYPE (<READ .CHAN>) TILDE>>
28
29 <DEFINE BACKQUOTE-READ-MACRO (CHAN CHAR) 
30    <BIND ((ORT:<OR FALSE <PRIMTYPE VECTOR>>
31            <COND (<ASSIGNED? READ-TABLE> .READ-TABLE) 
32                  (<GASSIGNED? READ-TABLE> ,READ-TABLE)>)
33           (NRT:<PRIMTYPE VECTOR> <STACK <IVECTOR 128 %<>>>))
34       <COND (.ORT
35              <SUBSTRUC .ORT 0 <LENGTH .ORT> .NRT>)>
36       <PUT .NRT %<+ <ASCII !\~> 1>
37            [!\~ !\A %<> ,TILDE-READ-MACRO %<>]>
38       <PROG ((READ-TABLE:<SPECIAL <PRIMTYPE VECTOR>> .NRT))
39          <BIND ((B <BACKQUOTIFY <READ .CHAN>>))
40             <COND (<TYPE? .B TILDE> <1 .B>) (ELSE <FORM QUOTE .B>)>>>>>
41
42 ;"Objects wrapped in a tilde should be evaluated.  All other objects should be
43   quoted.  BACKQUOTIFY's job is to return an object that contains no TILDEs,
44   although it may (and usually will) return an object of type TILDE to 
45   indicate that the EVALUATION of the contents is the object desired, not the
46   object itself.
47   
48   The convention of marking objects that should be evaluated with TILDE could
49   be changed to marking objects that should not be evaluated with QUOTE, but
50   since we expect most of the item to be quoted, this would be less efficient."
51
52 <DEFINE BACKQUOTIFY (OBJ) 
53    <COND
54     ;"If the object needs to be evaluated, or couldn't contain any TILDEs,
55       then pass it on."
56     (<OR <TYPE? .OBJ TILDE> <MONAD? .OBJ>> .OBJ)
57     (ELSE
58      <BIND ((PTYP:ATOM <PRIMTYPE .OBJ>))
59         ;"Only lists and vectors can contain interesting objects (like TILDEs),
60           so any other primtype can just be passed on like the monads."
61         <COND
62          (<==? .PTYP LIST>
63           <BIND ((FLAG:<OR FALSE TILDE> %<>))
64              ;"BACKQUOTIFY each of the sub-objects, and remember the last one
65                that came back tilded."
66              <MAPR %<>
67                    <FUNCTION (ROBJ "AUX" B) 
68                       <1 .ROBJ <SET B <BACKQUOTIFY <1 .ROBJ>>>>
69                       <COND (<TYPE? .B TILDE> <SET FLAG .B>)>>
70                    .OBJ:<PRIMTYPE LIST>>
71              <COND
72               ;"If there was a tilded one, then remove the tildes on the 
73                sub-objects, quote the un-tilded objects that need quotes,
74                and wrap a tlde around the whole thing.  In other words,
75                create an object that wll evaluate to the desired object.
76                
77                If enough objects (three or more in the interpreter, one or
78                more in the compiler) at the end of the list are quoted, use
79                the !'(...) trick to avoid copying list structure."
80               (.FLAG
81                <MAPR %<>
82                      <FUNCTION (ROBJ "AUX" (SUBOBJ <1 .ROBJ>)) 
83                         <COND
84                          (<TYPE? .SUBOBJ TILDE>
85                           <1 .ROBJ <1 .SUBOBJ>>
86                           <COND (<AND <==? .SUBOBJ .FLAG>
87                                       <NOT <LENGTH? 
88                                             .ROBJ 
89                                             <COND (<FEATURE? "COMPILER"> 0)
90                                                   (ELSE 2)>>>>
91                                  <PUTREST .ROBJ
92                                           (<CHTYPE (QUOTE <REST .ROBJ>) 
93                                                    SEGMENT>)>
94                                  <MAPLEAVE>)>)
95                          (<NOT <TYPE? .SUBOBJ
96                                       ATOM FIX FLOAT STRING BYTES UVECTOR>>
97                           ;"the list of self-quoting objects that I trust"
98                           <1 .ROBJ <FORM QUOTE .SUBOBJ>>)>>
99                      .OBJ:<PRIMTYPE LIST>>
100                ;"Make sure the object evaluates to the right type, shove it in
101                  a tilde, and return it."
102                <COND (<NOT <TYPE? .OBJ LIST>>
103                       <SET OBJ <FORM CHTYPE <CHTYPE .OBJ LIST> <TYPE .OBJ>>>)>
104                <1 .FLAG .OBJ>
105                .FLAG)
106               ;"If all of the sub-objects were quoted, just return the
107                 (now un-tilded) object."
108               (ELSE .OBJ)>>)
109          (<==? .PTYP VECTOR>
110           ;"All of the comments for lists apply to vectors, except for the 
111             !'(...) trick."
112           <BIND ((FLAG %<>))
113              #DECL ((FLAG) <OR FALSE TILDE>)
114              <MAPR %<>
115                    <FUNCTION (ROBJ "AUX" B) 
116                       <1 .ROBJ <SET B <BACKQUOTIFY <1 .ROBJ>>>>
117                       <COND (<TYPE? .B TILDE> <SET FLAG .B>)>>
118                    .OBJ:<PRIMTYPE VECTOR>>
119              <COND (.FLAG
120                     <MAPR %<>
121                           <FUNCTION (ROBJ "AUX" (SUBOBJ <1 .ROBJ>)) 
122                              <COND (<TYPE? .SUBOBJ TILDE>
123                                     <1 .ROBJ <1 .SUBOBJ>>)
124                                    (<NOT <TYPE? .SUBOBJ 
125                                                 ATOM FIX FLOAT STRING BYTES 
126                                                 UVECTOR>>
127                                     ;"the list of self-quoting objects that
128                                       I trust"
129                                     <1 .ROBJ <FORM QUOTE .SUBOBJ>>)>>
130                           .OBJ:<PRIMTYPE VECTOR>>
131                     <COND (<NOT <TYPE? .OBJ VECTOR>>
132                            <SET OBJ
133                                 <FORM CHTYPE
134                                       <CHTYPE .OBJ VECTOR>
135                                       <TYPE .OBJ>>>)>
136                     <1 .FLAG .OBJ>
137                     .FLAG)
138                    (ELSE .OBJ)>>)
139          (ELSE .OBJ)>>)>>
140
141 <DEFINE BACKQUOTE-INIT ("AUX" RT:<PRIMTYPE VECTOR>)
142    <COND (<GASSIGNED? READ-TABLE>
143           <BIND ((GRT:<OR FALSE VECTOR> ,READ-TABLE))
144              <COND (.GRT
145                     <COND (<L? <LENGTH .GRT> 128>
146                            <BIND ((NRT <IVECTOR 128 %<>>))
147                                 <SUBSTRUC .GRT 0 <LENGTH .GRT> .NRT>
148                                 <SET RT .NRT>>)
149                           (ELSE <SET RT .GRT>)>)
150                    (ELSE <SET RT <IVECTOR 128 %<>>>)>>)
151          (ELSE <SET RT <IVECTOR 128 %<>>>)>
152    <PUT .RT %<+ <ASCII !\`> 1>
153         [!\` !\A %<> ,BACKQUOTE-READ-MACRO %<>]>
154    <SETG READ-TABLE .RT>
155    <REPEAT ((LBIND:<OR FALSE LBIND> <CALL NTHR READ-TABLE ,M$$LVAL>))
156       <COND (.LBIND
157              <BIND ((LVAL <CALL NTHR .LBIND ,M$$VALU>))
158                 <COND (<TYPE? .LVAL UNBOUND FALSE>
159                        <CALL PUTR .LBIND ,M$$VALU .RT>)
160                       (ELSE
161                        <BIND ((LRT:<PRIMTYPE VECTOR> .LVAL))
162                           <COND (<L? <LENGTH .LRT> 128>
163                                  <BIND ((NRT:VECTOR <IVECTOR 128 %<>>))
164                                     <SUBSTRUC .LRT 0 <LENGTH .LRT> .NRT>
165                                     <SET LRT .NRT>>)>
166                           <CALL PUTR .LBIND ,M$$VALU .LRT>
167                           <PUT .LRT %<+ <ASCII !\`> 1>
168                                [!\` !\A %<> ,BACKQUOTE-READ-MACRO %<>]>>)>>
169              <SET LBIND <CALL NTHR .LBIND ,M$$PATM>>)
170             (ELSE <RETURN>)>>
171    T>
172
173 <COND (<AND <GASSIGNED? BACKQUOTE-INIT>
174             <TYPE? ,BACKQUOTE-INIT MSUBR>>
175        <BACKQUOTE-INIT>)>
176        
177 <ENDPACKAGE>