stdlib/parser/parse.mud

   1 ;"Copyright (C) 2018 Keziah Wesley
   2
   3 You can redistribute and/or modify this file under the terms of the
   4 GNU Affero General Public License as published by the Free Software
   5 Foundation, either version 3 of the License, or (at your option) any
   6 later version.
   7
   8 This file is distributed in the hope that it will be useful, but
   9 WITHOUT ANY WARRANTY; without even the implied warranty of
  10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11 Affero General Public License for more details.
  12
  13 You should have received a copy of the GNU Affero General Public
  14 License along with this file. If not, see
  15 <http://www.gnu.org/licenses/>."
  16
  17 <FLOAD "chartable.mud">
  18
  19 <MOBLIST PARSER>
  20
  21 parse!-
  22 PARSE-TABLE!-
  23
  24 DEFAULT-TABLE!-PARSER
  25
  26 read-all!-PARSER
  27
  28 %<AND <BLOCK (<MOBLIST pp> <GET PARSER OBLIST> <GET CHARTABLE OBLIST> <ROOT>)> <>>
  29
  30 ;"Operation:
  31   Input string is provided to parser. Parser consumes from input and updates state.
  32   Beginning and end of input will be treated as token boundaries.
  33   Parser will return producing a value after reading 1 complete expression
  34   (possibly leaving some input leftover)."
  35
  36 ;"If PARSE receives a partial input, it emits an ERROR. READ installs a
  37   handler for the ERROR INTERRUPT that attempts to get more data and
  38   ERRET."
  39
  40 <DEFINE CHARSTREAM (s) [.s 1 1]>
  41 <DEFINE COPY-CHARSTREAM (s) <MAPF ,VECTOR ,AND? .s>>
  42 <DEFINE SET-CHARSTREAM (x y) <PUT .x 1 <1 .y>> <PUT .x 2 <2 .y>> <PUT .x 3 <3 .y>>>
  43 <DEFINE NEWLINE-POS (s) <PUT .s 2 <+ 1 <2 .s>>> <PUT .s 3 0>>
  44 <DEFINE GET-POS (x) (<2 .x> <3 .x>)>
  45 <DEFINE EAT-CHAR (s) <PUT .s 1 <REST <1 .s>>> <PUT .s 3 <+ 1 <3 .s>>>>
  46 <DEFINE PEEK-CHAR (s) <ASCII <1 <1 .s>>>>
  47 <DEFINE NEXT-CHAR (s "AUX" (c <PEEK-CHAR .s>))
  48  <EAT-CHAR .s>
  49  <COND (<==? 33 .c> <SET c <bang <PEEK-CHAR .s>>> <EAT-CHAR .s>)>
  50  .c>
  51 ;"TODO: eliminate this and rely on peeking"
  52 <DEFINE RETURN-CHAR (s "AUX")
  53  <COND (<==? %<ASCII 10> <1 <BACK <1 .s>>>> <PUT .s 2 <- <2 .s> 1>>)>
  54  <PUT .s 1 <BACK <1 .s>>>>
  55
  56 <DEFINE parse (t s "AUX" c sp "NAME" a)
  57  <COND (<EMPTY? <1 .s>> <RETURN EOF .a>)>
  58  <SET c <NEXT-CHAR .s>>
  59  <SET sp <SPECIAL? .t .c>>
  60  <COND (.sp <APPLY .sp .t .s .a>)
  61        (ELSE <APPLY <DEFAULT-HANDLER .t> .t .c .s .a>)>>
  62
  63 ;"BLOCK is documented as modifying the value of .OBLIST, so I'm
  64   assuming passing a lookup param to READ has a similar effect rather
  65   than setting an internal variable."
  66
  67 <DEFINE read (s "OPTIONAL" (OBLIST .OBLIST))
  68  <parse ,default <CHARSTREAM .s>>>
  69
  70 <DEFINE read-all (s "OPTIONAL" (OBLIST .OBLIST))
  71  <SET s <CHARSTREAM .s>>
  72  <MAPF ,LIST <FUNCTION ("AUX" res)
  73   <COND (<EMPTY? <1 .s>> <MAPSTOP>)
  74         (ELSE <SET res <parse ,default .s>>
  75          <COND (<==? .res EOF> <MAPSTOP>) (ELSE .res)>)>>>>
  76
  77 ;"Don't try to READ in objects of these types."
  78 <NEWTYPE closer FIX>
  79 <NEWTYPE prototemplate VECTOR>
  80 ;"TODO: set appropriate ERROR as closer's EVALTYPE."
  81
  82 <DEFINE bang (c) <+ .c #FIX %<LSH 1 21>>>
  83 <DEFINE banged? (c) <G=? .c #FIX %<LSH 1 21>>>
  84 <DEFINE unbang (c) <- .c #FIX %<LSH 1 21>>>
  85 <DEFINE explode-bang (c)
  86  <COND (<banged? .c> <STRING %<1 "!"> <CHTYPE .c CHARACTER>>) (ELSE <CHTYPE .c CHARACTER>)>>
  87
  88 ;"Create the appropriate ERROR if there's a brace mismatch."
  89 ;"Otherwise do nothing. Return value is ignored."
  90 <DEFINE check-closer (pos c opener s "TUPLE" closers)
  91  <COND
  92   (<TYPE? .c closer>
  93    <COND
  94     (<MEMQ <CHTYPE .c FIX> .closers>)
  95     ;"TODO: position info"
  96     (ELSE <ERROR BRACE-MISMATCH (POS .pos
  97                                  OPENER <explode-bang .opener>
  98                                  EXPECTED <MAPF ,LIST ,explode-bang .closers>
  99                                  FOUND <explode-bang <CHTYPE .c FIX>>)>)>)
 100   (<==? .c EOF> <ERROR UNCLOSED-BRACKET <explode-bang .opener> .pos>)>>
 101
 102 ;"TODO: accept radix in PARSE"
 103 <SETG radix 10>
 104
 105 ;"Create a standard Muddle CHARTABLE."
 106 <DEFINE make-default ("AUX" (t <CHARTABLE>))
 107  <BULK-UPDATE .t
 108   <SET-SPECIAL .t 9 T <FUNCTION (t s a) <AGAIN .a>>> ;"HT"
 109   <SET-SPECIAL .t 10 T <FUNCTION (t s a) <NEWLINE-POS .s> <AGAIN .a>>> ;"LF"
 110   <SET-SPECIAL .t 11 T <FUNCTION (t s a) <AGAIN .a>>> ;"VT"
 111   <SET-SPECIAL .t 12 T <FUNCTION (t s a) <AGAIN .a>>> ;"FF"
 112   <SET-SPECIAL .t 13 T <FUNCTION (t s a) <AGAIN .a>>> ;"CR"
 113   <SET-SPECIAL .t 32 T <FUNCTION (t s a) <AGAIN .a>>> ;"space"
 114   <SET-SPECIAL .t <ASCII !\.> <> <FUNCTION (t s a) <FORM LVAL <parse .t .s>>>>
 115   <SET-SPECIAL .t <ASCII !\,> T <FUNCTION (t s a) <FORM GVAL <parse .t .s>>>>
 116   <SET-SPECIAL .t <bang <ASCII !\.>> <> <FUNCTION (t s a) <CHTYPE <FORM LVAL <parse .t .s>> SEGMENT>>>
 117   <SET-SPECIAL .t <bang <ASCII !\,>> T <FUNCTION (t s a) <CHTYPE <FORM GVAL <parse .t .s>> SEGMENT>>>
 118   <SET-SPECIAL .t <ASCII !\'> T <FUNCTION (t s a) <FORM QUOTE <parse .t .s>>>>
 119   <SET-SPECIAL .t <ASCII !\;> T <FUNCTION (t s a) <parse .t .s> <AGAIN .a>>>
 120   <SET-SPECIAL .t <ASCII !\%> T <FUNCTION (t s a)
 121    <COND (<==? %<ASCII !\%> <PEEK-CHAR .s>> <EAT-CHAR .s> <EVAL <parse .t .s>> <AGAIN .a>)>
 122    <EVAL <parse .t .s>>>>
 123   <SET-SPECIAL .t <ASCII !\#> T <FUNCTION (t s a "AUX" (type <parse .t .s>)) <CHTYPE <parse .t .s> .type>>>
 124   <SET-SPECIAL .t <bang <ASCII !\\>> T <FUNCTION (t s a) <NEXT-CHAR .s>>>
 125   <SET-SPECIAL .t <ASCII !\*> <> <FUNCTION (t s a) <parse-octal .t .s .a>>>
 126
 127   <SET-SPECIAL .t <ASCII !\"> T <FUNCTION (t s a)
 128    <MAPF ,STRING <FUNCTION ("AUX" (c <NEXT-CHAR .s>))
 129     <COND (<==? .c %<ASCII !\\>> <MAPRET <CHTYPE <NEXT-CHAR .s> CHARACTER>>)
 130           (<banged? .c> <MAPRET %<1 "!"> <CHTYPE <unbang .c> CHARACTER>>)
 131           (<==? .c %<ASCII !\">> <MAPSTOP>)
 132           (<==? .c 10> <NEWLINE-POS .s> <MAPRET <CHTYPE .c CHARACTER>>)
 133           (ELSE <MAPRET <CHTYPE .c CHARACTER>>)>>>>>
 134
 135   ;"TODO: macros for reducing the redundancy of all these openers and closers."
 136
 137   ;"A closer is an illegal object for anything except the corresponding opener."
 138   <SET-SPECIAL .t <ASCII !\>> T <FUNCTION (t s a) <CHTYPE <ASCII !\>> closer>>>
 139   <SET-SPECIAL .t <ASCII !\)> T <FUNCTION (t s a) <CHTYPE <ASCII !\)> closer>>>
 140   <SET-SPECIAL .t <ASCII !\]> T <FUNCTION (t s a) <CHTYPE <ASCII !\]> closer>>>
 141   <SET-SPECIAL .t <ASCII !\}> T <FUNCTION (t s a) <CHTYPE <ASCII !\}> closer>>>
 142   <SET-SPECIAL .t <bang <ASCII !\>>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\>>> closer>>>
 143   <SET-SPECIAL .t <bang <ASCII !\)>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\)>> closer>>>
 144   <SET-SPECIAL .t <bang <ASCII !\]>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\]>> closer>>>
 145   <SET-SPECIAL .t <bang <ASCII !\}>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\}>> closer>>>
 146
 147   <SET-SPECIAL .t <ASCII !\(> T <FUNCTION (t s a "AUX" pos)
 148    <SET pos <GET-POS .s>>
 149    <MAPF ,LIST <FUNCTION ("AUX" (x <parse .t .s>))
 150     <COND (<check-closer .x <ASCII !\(> .s <ASCII !\)>> <MAPSTOP>)
 151           (ELSE <MAPRET .x>)>>>>>
 152
 153   <SET-SPECIAL .t <ASCII !\<> T <FUNCTION (t s a "AUX" pos)
 154    <SET pos <GET-POS .s>>
 155    <MAPF ,FORM <FUNCTION ("AUX" (x <parse .t .s>))
 156     <COND (<check-closer .pos .x <ASCII !\<> .s <ASCII !\>>> <MAPSTOP>)
 157           (ELSE <MAPRET .x>)>>>>>
 158
 159   <SET-SPECIAL .t <ASCII !\[> T <FUNCTION (t s a "AUX" pos)
 160    <SET pos <GET-POS .s>>
 161    <MAPF ,VECTOR <FUNCTION ("AUX" (x <parse .t .s>))
 162     <COND (<check-closer .pos .x <ASCII !\[> .s <ASCII !\]>> <MAPSTOP>)
 163           (ELSE <MAPRET .x>)>>>>>
 164
 165   <SET-SPECIAL .t <bang <ASCII !\[>> T <FUNCTION (t s a "AUX" pos)
 166    <SET pos <GET-POS .s>>
 167    <MAPF ,UVECTOR <FUNCTION ("AUX" (x <parse .t .s>))
 168     <COND (<check-closer .pos .x <bang <ASCII !\[>> .s <ASCII !\]>> <bang <ASCII !\]>> <MAPSTOP>)
 169           (ELSE <MAPRET .x>)>>>>>
 170
 171   <SET-SPECIAL .t <bang <ASCII !\<>> T <FUNCTION (t s a "AUX" pos)
 172    <SET pos <GET-POS .s>>
 173    <CHTYPE <MAPF ,FORM <FUNCTION ("AUX" (x <parse .t .s>))
 174     <COND (<check-closer .pos .x <bang <ASCII !\<>> .s <ASCII !\>>> <bang <ASCII !\>>> <MAPSTOP>)
 175           (ELSE <MAPRET .x>)>>> SEGMENT>>>
 176
 177   ;"The prototemplate returned is an illegal object for anything except #-syntax."
 178   <SET-SPECIAL .t <ASCII !\{> T <FUNCTION (t s a "AUX" pos)
 179    <SET pos <GET-POS .s>>
 180    <CHTYPE <MAPF ,VECTOR <FUNCTION ("AUX" (x <parse .t .s>))
 181     <COND (<check-closer .pos .x <ASCII !\{> .s <ASCII !\}>> <MAPSTOP>)
 182           (ELSE <MAPRET .x>)>>> prototemplate>>>
 183
 184   ;"Plain backslash just gets default handling in the lexer. It's only
 185     special to the scalar sublexer."
 186
 187   <SET-DEFAULT .t ,parse-scalar>>>
 188
 189 ;"Lookup a string in an OBLIST / OBLIST list. If it isn't found,
 190   insert it into the OBLIST / head of the OBLIST list."
 191 <DEFINE lookup-multi (a os)
 192  <COND (<TYPE? .os OBLIST> <OR <LOOKUP .a .os> <INSERT .a .os>>)
 193        (ELSE <OR <MAPF <> <FUNCTION (o "AUX" (atm <LOOKUP .a .o>))
 194                            <COND (.atm <MAPLEAVE .atm>)>> .os>
 195                  <INSERT .a <1 .os>>>)>>
 196
 197 ;"TODO: BLOCK..."
 198 <DEFINE parse-atom (t s a "AUX" (atoms ()) atm pn is-trailed "NAME" getpn)
 199  ;"Copy up to any trailer into a temporary STRING."
 200  <SET is-trailed <>>
 201  <SET pn <MAPF ,STRING <FUNCTION ("AUX" (k <PEEK-CHAR .s>))
 202   <COND (<BREAKER? .t .k> <MAPSTOP>)
 203         (<==? .k %<bang <ASCII !\->>> <SET is-trailed T> <EAT-CHAR .s> <MAPSTOP>)
 204         (<banged? .k> <EAT-CHAR .s> <MAPRET %<1 "!"> <CHTYPE <unbang .k> CHARACTER>>)
 205         (ELSE <EAT-CHAR .s> <MAPRET <CHTYPE .k CHARACTER>>)>>>>
 206  ;"Gather trailer-separated PNAMEs into a stack."
 207  <COND (.is-trailed <SET atoms (.pn !.atoms)> <AGAIN .getpn>)>
 208  ;"Now we have a LIST of STRINGs containing our trailed PNAMEs, with
 209    the last still in .pn. The final PNAME is special: because it has
 210    no trailer, we look it up in our oblist list."
 211  <COND
 212   (<EMPTY? .pn> <ROOT>
 213    ;"Special case: we have an OBLIST, not an ATOM identifying an OBLIST."
 214    <SET atm <OR <LOOKUP <1 .atoms> .atm> <INSERT <1 .atoms> .atm>>>
 215    <SET atoms <REST .atoms>>)
 216   (ELSE <SET atm <lookup-multi .pn .OBLIST>>)>
 217  <COND (<EMPTY? .atoms> <RETURN .atm .getpn>)>
 218  ;"Lookup each atom in the oblist denoted the previous (trailer),"
 219  ;"except the last, which is our ATOM."
 220  <MAPF <>
 221   <FUNCTION (x "AUX" ob)
 222    <SET ob <MOBLIST .atm>>
 223    <SET atm <OR <LOOKUP .x .ob> <INSERT .x .ob>>>>
 224   .atoms>>
 225
 226 <DEFINE parse-octal (t s a "AUX" (z <COPY-CHARSTREAM .s>) c (n 0) (havedigits <>) "NAME" oct)
 227  <SET c <NEXT-CHAR .z>>
 228  <COND
 229   ;"Ended without a trailing *?"
 230   (<BREAKER? .t .c> <RETURN-CHAR .s> <parse-atom .t .s .a>)
 231   ;"Made it to *?"
 232   (<==? .c %<ASCII !\*>>
 233    <COND (.havedigits <SET-CHARSTREAM .s .z> <RETURN <CHTYPE .n FIX> .a>)
 234          (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>)
 235   ;"Got another octit?"
 236   (<AND <L=? %<ASCII !\0> .c> <L=? .c %<ASCII !\9>>>
 237    <SET n <ORB <- .c %<ASCII !\0>> <LSH .n 3>>>
 238    <SET havedigits T>
 239    <AGAIN .oct>)
 240   ;"Not octal after all."
 241   (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>>
 242
 243 ;"If current radix isn't 10, pre-scan to see whether there's a decimal point."
 244 <DEFINE num-rad (s)
 245  <COND
 246   (<==? ,radix 10> 10)
 247   (ELSE
 248    <REPEAT ((z <COPY-CHARSTREAM .s>) "NAME" rdx)
 249     <SET c <NEXT-CHAR .z>>
 250     <COND (<BREAKER? .t .c> <RETURN ,radix .rdx>)
 251       ;"Docs aren't clear on exponent-notation fixes without decimal points."
 252       ;"Decimal makes more sense..."
 253       (<==? %<ASCII !\e> .c> <RETURN 10 .rdx>)
 254       (<==? %<ASCII !\E> .c> <RETURN 10 .rdx>)
 255       (<==? %<ASCII !\.> .c> <RETURN 10 .rdx>)>>)>>
 256
 257 <DEFINE parse-decimal (t c s a "AUX" (havedigits <>) (n 0) (sgn 1) (z <COPY-CHARSTREAM .s>) (rad <num-rad .s>))
 258  <COND (<==? .c %<ASCII !\->> <SET sgn -1>)
 259        (ELSE <RETURN-CHAR .z> <SET havedigits T>)>
 260  <REPEAT ("NAME" decimal)
 261   <SET c <NEXT-CHAR .z>>
 262   <COND
 263    ;"Done?"
 264    (<BREAKER? .t .c>
 265     <COND (.havedigits <RETURN-CHAR .z> <SET-CHARSTREAM .s .z> <RETURN <* .n .sgn> .a>)
 266           (ELSE <RETURN-CHAR .s> <RETURN <parse-atom .t .s .a> .a>)>)
 267    ;"Got a digit?"
 268    (<AND <L=? %<ASCII !\0> .c> <L? .c <+ %<ASCII !\0> .rad>>>
 269     <SET n <+ <* .n .rad> <- .c %<ASCII !\0>>>>
 270     <SET havedigits T>)
 271    ;".?"
 272    ;"[eE]?"
 273    ;"Not a decimal."
 274    (ELSE <RETURN-CHAR .s> <RETURN <parse-atom .t .s .a> .a>)>>>
 275
 276 ;"The Scalar Sublexer."
 277 ;"Parse an object that begins with a non-special character: FIX/FLOAT/ATOM."
 278 <DEFINE parse-scalar (t c s a "AUX" rad)
 279  <COND
 280   (<OR <==? .c %<ASCII !\->> <AND <L=? %<ASCII !\0> .c> <L=? .c %<ASCII !\9>>>>
 281    <parse-decimal .t .c .s .a>)
 282   (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>>
 283
 284 ;"Fallback to use if PARSE-TABLE!- is empty and no argument is provided."
 285 <SETG default <make-default>>
 286 <DEFINE DEFAULT-TABLE () ,default>
 287
 288 %<AND <ENDBLOCK> <>>
 289
 290 ;"Like MAPF ,AND with early termination."
 291 <DEFINE ALL? (fn "TUPLE" argses "NAME" all)
 292  <MAPF <> <FUNCTION ("TUPLE" xs) <COND (<NOT <APPLY .fn !.xs>> <RETURN <> .all>)>> !.argses>
 293  T>
 294
 295 ;"This belongs in a PRINT module. Here for testing."
 296 <DEFINE PPRINT (x "OPTIONAL" (lvl 0))
 297  <COND
 298   (<TYPE? .x LIST> <PRINC !\(> <PPRINT-SEQ .x <+ .lvl 1>> <PRINC !\)>)
 299   (<AND <TYPE? .x FORM> <NOT <OR <EMPTY? .x> <==? <1 .x> LVAL> <==? <1 .x> GVAL>>>>
 300    <PRINC !\<> <PPRINT-SEQ .x <+ .lvl 1>> <PRINC !\>>)
 301   (ELSE <PRIN1 .x>)>>
 302 <DEFINE PPRINT-SEQ (x lvl)
 303  <COND (<EMPTY? .x>)
 304        ;"TODO: more aggressive single-lining"
 305        (<ALL? <FUNCTION (y) <OR <NOT <TYPE? .y FORM LIST>>
 306                                 <EMPTY? .y>
 307                                 <==? <1 .y> LVAL>
 308                                 <==? <1 .y> GVAL>>> .x>
 309         <PRIN1 <1 .x>>
 310         <MAPF <> <FUNCTION (y) <PRINC !\ > <PRIN1 .y>> <REST .x>>)
 311        (ELSE
 312         <PPRINT <1 .x> .lvl>
 313         <MAPF <> <FUNCTION (y) <CRLF> <INDENT .lvl> <PPRINT .y .lvl>> <REST .x>>)>>
 314 <DEFINE INDENT (lvl) <PRINC <ISTRING .lvl !\ >>>
 315
 316 <PROG ()
 317  <SET sss <ISTRING 40000>>
 318  <SET sss <SUBSTRUC .sss 0 <READSTRING .sss <OPEN "READB" "./chartable.mud">>>>
 319  <PPRINT <read-all!-PARSER .sss>>
 320  >
 321
 322 <QUIT>