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>