--- /dev/null
+;"Copyright (C) 2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>."
+
+;"CHARTABLE"
+
+;"A CHARTABLE maps reader-chars (Unicode chars optionally prefixed by
+ a !) to properties. All special handling of any character is defined
+ through CHARTABLE properties."
+
+;"Properties are of two varieties:
+ - Lexical classes. Each character is a member of 0 or more classes.
+ Class membership alone determines tokenization.
+ - Parse functions. Every SPECIAL character has an associated
+ function that handles creating any resultant object, including
+ PARSEing any children and matching delimiters, in
+ recursive-descent fashion."
+
+;"Lexical class combinations used by the standard parser:
+ [.] Special non-breaking: (SP)
+ [,] Special breaking: (SP BR)
+ [A] Unspecial: ()
+The behavior of a hypothetical non-special breaker is currently
+unspecified: e.g. defining * as (BR) may cause *a* to parse as 2 or 3
+unspecial tokens."
+
+;"One category is particularly interesting: unspecial tokens, parsed
+ by DEFAULT-HANDLER. The parser for unspecials has to distinguish
+ between atoms and the various numeric encodings, but in all cases
+ its outward behavior is the same: it consumes a non-SP followed by
+ zero or more non-BR, and then pushes some kind of object onto the
+ result stack. It's important to note that this scalar-decoding
+ mechanism is independent of lexical classes, other than those
+ necessary to delimit the sequence--a character may have a different
+ meaning as part of an unspecial token."
+
+;"The current implementation is simple, and reasonably efficient under
+ typical circumstances (lots of low codepoints in input, not too many
+ characters with properties defined). Rules are 'compiled' from an
+ editable format into a query-optimized data structure, which is
+ transparent to the user except that you'll want to use a BULK-UPDATE
+ block if you have many edits to make and want to avoid spending time
+ on unneeded intermediate recompiles."
+
+<MOBLIST CHARTABLE>
+
+;"Querying table contents"
+BREAKER?!-CHARTABLE
+SPECIAL?!-CHARTABLE
+DEFAULT-HANDLER!-CHARTABLE
+
+;"Creating / updating tables"
+CHARTABLE!-CHARTABLE
+SET-SPECIAL!-CHARTABLE
+SET-UNSPECIAL!-CHARTABLE
+SET-DEFAULT!-CHARTABLE
+BULK-UPDATE!-CHARTABLE
+
+;"Confusion can't %%"
+%<AND <BLOCK (<MOBLIST ct> <GET CHARTABLE OBLIST> <ROOT>)> <>>
+
+;"Lowest 21-bits: Unicode codepoint"
+;"Highest non-sign bit: flag indicating ! prefix"
+<NEWTYPE RCHAR FIX>
+
+<NEWTYPE CTABLE VECTOR>
+;"SRC: LIST (rchar)"
+;"compiled: range table [start . post]"
+<SETG is-breaker 1>
+;"SRC: LIST (rchar)"
+;"compiled: extended range table [start . post . index]"
+<SETG is-special 2>
+;"SRC: LIST ((rchar handler) !rest)"
+;"compiled: vector of functions, ordered by char"
+<SETG handlers 3>
+;"Compiled: points to read table data in editable data structures."
+;"Simpler to keep the source data than decompile the range tables."
+<SETG rt-src 4>
+;"Keep track of BULK-UPDATEs in progress."
+<SETG batch-depth 5>
+<SETG is-dirty 6>
+<SETG default 7>
+
+;"--- edit operations (SRC tables) ---"
+
+;"TODO: factor out redundancy between all these list-removers. Macro?"
+
+<DEFINE set-is-breaker (src char val)
+ ;"Remove from breakers whether setting or clearing. (Prevent dupes)."
+ <PUT .src ,is-breaker
+ <MAPF ,LIST <FUNCTION (x)
+ <COND (<==? .x .char> <MAPRET>) (ELSE <MAPRET .x>)>>
+ <is-breaker .src>>>
+ ;"(Re-)add to breakers if setting."
+ <COND (.val <PUT .src ,is-breaker (.char !<is-breaker .src>)>)>>
+
+<DEFINE remove-special (src char)
+ <PUT .src ,is-special
+ <MAPF ,LIST <FUNCTION (x)
+ <COND (<==? .x .char> <MAPRET>) (ELSE <MAPRET .x>)>>
+ <is-special .src>>>>
+
+<DEFINE remove-handler (src char)
+ <PUT .src ,handlers
+ <MAPF ,LIST <FUNCTION (x)
+ <COND (<==? <1 .x> .char> <MAPRET>) (ELSE <MAPRET .x>)>>
+ <handlers .src>>>>
+
+<DEFINE SET-UNSPECIAL (tab char "OPTIONAL" (is-breaker #FALSE ()) "AUX" (src <rt-src .tab>))
+ <remove-special .src .char>
+ <remove-handler .src .char>
+ <set-is-breaker .src .char .is-breaker>
+ <maybe-recompile .tab>>
+
+<DEFINE SET-SPECIAL (tab char is-breaker fn "AUX" (src <rt-src .tab>))
+ ;"remove any previous specialness properties and update is-breaker"
+ <SET-UNSPECIAL .tab .char .is-breaker>
+ <PUT .src ,is-special (.char !<is-special .src>)>
+ <PUT .src ,handlers ((.char .fn) !<handlers .src>)>
+ <maybe-recompile .tab>>
+
+<DEFINE SET-DEFAULT (tab fn) <PUT .tab ,default .fn>>
+<DEFINE DEFAULT-HANDLER (tab) <NTH .tab ,default>>
+
+;"--- query operations (compiled tables) ---"
+
+;"Simple linear search implementation."
+
+;"Look up whether the character is a breaker."
+<DEFINE BREAKER? (t c "AUX" (breakers <is-breaker .t>) "NAME" act)
+ <COND
+ (<EMPTY? .breakers> <>)
+ (<L? .c <1 .breakers>> <>)
+ (<L? .c <2 .breakers>> T)
+ (ELSE <SET breakers <REST .breakers 2>> <AGAIN .act>)>>
+
+;"Look up whether the character is special. If it is, return its handler."
+<DEFINE SPECIAL? (t c "AUX" (specials <is-special .t>) "NAME" act)
+ <COND
+ (<EMPTY? .specials> <>)
+ (<L? .c <1 .specials>> <>)
+ (<L? .c <2 .specials>> <NTH <handlers .t> <- .c <3 .specials>>>)
+ (ELSE <SET specials <REST .specials 3>> <AGAIN .act>)>>
+
+;"--- other ---"
+
+;"Create a new empty CHARTABLE."
+<DEFINE CHARTABLE () <CHTYPE [![] ![] ![] (() () ()) 0 <> <>] CTABLE>>
+
+<DEFINE end-update (tab)
+ <PUT .tab ,batch-depth <- <batch-depth .tab> 1>>
+ <is-dirty .tab>
+ <maybe-recompile .tab>
+ .tab>
+
+;"defer any recompiles to the end of the block"
+<DEFINE BULK-UPDATE (tab "ARGS" stmts)
+ <PUT .tab ,batch-depth <+ <batch-depth .tab> 1>>
+ <UNWIND <MAPF <> ,EVAL .stmts> <end-update .tab>>
+ <end-update .tab>>
+
+;"Call after modifying the table. Will recompile now, or later if
+ there's a BULK-UPDATE in progress."
+<DEFINE maybe-recompile (t)
+ <COND (<0? <batch-depth .t>> <recompile .t>)
+ (ELSE <PUT .t ,is-dirty T>)>>
+
+<DEFINE sorted (xs) <SORT <> ![!.xs!]>>
+
+<DEFINE count-spans (v "AUX" (pv -2) (n 0) "NAME" act)
+ <COND (<EMPTY? .v> <RETURN .n .act>)
+ (<L? 1 <- <1 .v> .pv>> <SET n <+ 1 .n>>)>
+ <SET pv <1 .v>>
+ <SET v <REST .v>>
+ <AGAIN .act>>
+
+<SETG std 2>
+<SETG ext 3>
+
+;"Given a list of values, return a rangetable: [begin end...]"
+<DEFINE make-rt (xs)
+ <COND (<EMPTY? .xs> ![])
+ (ELSE <make-rt-imp std <sorted .xs>>)>>
+
+;"Given a list of values, return an extended rangetable: [begin end running-excluded...]"
+<DEFINE make-ext-rt (xs)
+ <COND (<EMPTY? .xs> ![])
+ (ELSE <make-rt-imp ext <sorted .xs>>)>>
+
+<DEFINE make-rt-imp (type v "AUX"
+ (rt <IUVECTOR <* ,.type <count-spans .v>> 0>)
+ (t .rt)
+ (gaps <- <1 .v> 1>)
+ pv
+ "NAME" act)
+ ;"Begin a span."
+ <PUT .t 1 <SET pv <1 .v>>>
+ <SET v <REST .v>>
+ ;"Advance v until it points to a value beyond the span."
+ <REPEAT ("NAME" span)
+ <SET pv <+ 1 .pv>> ;"increment prev in advance"
+ <COND (<COND (<EMPTY? .v> <RETURN <> .span>)>)
+ (<==? <1 .v> .pv> <SET v <REST .v>>)
+ (ELSE <RETURN <> .span>)>>
+ ;"End the span. pv is the first value missing. <1 .v> will begin the next span."
+ <PUT .t 2 .pv>
+ <COND (<==? .type ext> <PUT .t 3 .gaps>)>
+ <SET t <REST .t ,.type>>
+ <COND (<EMPTY? .v> <RETURN .rt .act>)>
+ <SET gaps <+ .gaps <- <1 .v> .pv>>>
+ <AGAIN .act>>
+
+;"XXX: Confusion's sort is crashy with predicates."
+;<DEFINE sort-handlers (xs) <MAPF ,UVECTOR 2 <SORT <FUNCTION (a b) <G? <1 .a> <1 .b>>> ![!.xs]>>>
+;"XXX: Confusion's sort ignores the second sequence."
+;<DEFINE sort-handlers (xs "AUX" (keys <MAPF ,UVECTOR 1 .xs>) (vals <MAPF ,UVECTOR 2 .xs>))
+ <SORT <> .keys 1 0 .vals>
+ .vals>
+
+;"Given a sequence of (key value) pairs, return a vector of the values
+ sorted by their keys."
+<DEFINE sort-handlers (xs "AUX"
+ ;"Zip the inputs."
+ (kv <MAPF ,VECTOR ,MAPRET <MAPF ,UVECTOR 1 .xs> <MAPF ,UVECTOR 2 .xs>>))
+ ;"Sort zipped inputs."
+ <SORT <> .kv 2 0>
+ ;"Gather every 2nd value."
+ <MAPR ,UVECTOR <FUNCTION (xs)
+ <COND (<==? #WORD 0 <ANDB 1 <LENGTH .xs>>> <MAPRET>)
+ (ELSE <MAPRET <1 .xs>>)>> .kv>>
+
+;"Rebuild the table to incorporate any new modifications."
+<DEFINE recompile (t "AUX" (src <rt-src .t>))
+ <PUT .t ,is-breaker <make-rt <is-breaker .src>>>
+ <PUT .t ,is-special <make-ext-rt <is-special .src>>>
+ <PUT .t ,handlers <sort-handlers <handlers .src>>>
+ <PUT .t ,is-dirty #FALSE ()>>
+
+%<AND <ENDBLOCK> <>>
+
+;<DEFINE assert ('x "AUX" (ex <EVAL .x>)) <COND (<NOT .ex> <ERROR ASSERT-FAILED .x .ex>)>>
+;<DEFINE assert-eq ('x 'y "AUX" (ex <EVAL .x>) (ey <EVAL .y>))
+ <COND (<N=? .ex .ey> <ERROR ASSERT-FAILED (.x .y) (.ex .ey)>)>>
+
+;<PROG ((t <CHARTABLE!-CHARTABLE>))
+ <PRINT (PRE .t)>
+ <assert <NOT <SPECIAL?!-CHARTABLE .t *007*>>>
+ <assert <NOT <BREAKER?!-CHARTABLE .t *007*>>>
+ <SET-SPECIAL!-CHARTABLE .t *007* T <FUNCTION () 5>>
+ <SET-SPECIAL!-CHARTABLE .t *006* T <FUNCTION () 3>>
+ <PRINT (POST .t)>
+ <assert <SPECIAL?!-CHARTABLE .t *007*>>
+ <assert <BREAKER?!-CHARTABLE .t *007*>>
+ <BULK-UPDATE!-CHARTABLE .t
+ <SET-UNSPECIAL!-CHARTABLE .t *007*>>
+ <PRINT (POST-UN .t)>
+ <assert <NOT <SPECIAL?!-CHARTABLE .t *007*>>>
+ <assert <NOT <BREAKER?!-CHARTABLE .t *007*>>>
+ <TERPRI>>
+
+;"Confusion needs this."
+<>
--- /dev/null
+;"Copyright (C) 2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>."
+
+<FLOAD "chartable.mud">
+
+<MOBLIST PARSER>
+
+parse!-
+PARSE-TABLE!-
+
+DEFAULT-TABLE!-PARSER
+
+read-all!-PARSER
+
+%<AND <BLOCK (<MOBLIST pp> <GET PARSER OBLIST> <GET CHARTABLE OBLIST> <ROOT>)> <>>
+
+;"Operation:
+ Input string is provided to parser. Parser consumes from input and updates state.
+ Beginning and end of input will be treated as token boundaries.
+ Parser will return producing a value after reading 1 complete expression
+ (possibly leaving some input leftover)."
+
+;"If PARSE receives a partial input, it emits an ERROR. READ installs a
+ handler for the ERROR INTERRUPT that attempts to get more data and
+ ERRET."
+
+<DEFINE CHARSTREAM (s) [.s 1 1]>
+<DEFINE COPY-CHARSTREAM (s) <MAPF ,VECTOR ,AND? .s>>
+<DEFINE SET-CHARSTREAM (x y) <PUT .x 1 <1 .y>> <PUT .x 2 <2 .y>> <PUT .x 3 <3 .y>>>
+<DEFINE NEWLINE-POS (s) <PUT .s 2 <+ 1 <2 .s>>> <PUT .s 3 0>>
+<DEFINE GET-POS (x) (<2 .x> <3 .x>)>
+<DEFINE EAT-CHAR (s) <PUT .s 1 <REST <1 .s>>> <PUT .s 3 <+ 1 <3 .s>>>>
+<DEFINE PEEK-CHAR (s) <ASCII <1 <1 .s>>>>
+<DEFINE NEXT-CHAR (s "AUX" (c <PEEK-CHAR .s>))
+ <EAT-CHAR .s>
+ <COND (<==? 33 .c> <SET c <bang <PEEK-CHAR .s>>> <EAT-CHAR .s>)>
+ .c>
+;"TODO: eliminate this and rely on peeking"
+<DEFINE RETURN-CHAR (s "AUX")
+ <COND (<==? %<ASCII 10> <1 <BACK <1 .s>>>> <PUT .s 2 <- <2 .s> 1>>)>
+ <PUT .s 1 <BACK <1 .s>>>>
+
+<DEFINE parse (t s "AUX" c sp "NAME" a)
+ <COND (<EMPTY? <1 .s>> <RETURN EOF .a>)>
+ <SET c <NEXT-CHAR .s>>
+ <SET sp <SPECIAL? .t .c>>
+ <COND (.sp <APPLY .sp .t .s .a>)
+ (ELSE <APPLY <DEFAULT-HANDLER .t> .t .c .s .a>)>>
+
+;"BLOCK is documented as modifying the value of .OBLIST, so I'm
+ assuming passing a lookup param to READ has a similar effect rather
+ than setting an internal variable."
+
+<DEFINE read (s "OPTIONAL" (OBLIST .OBLIST))
+ <parse ,default <CHARSTREAM .s>>>
+
+<DEFINE read-all (s "OPTIONAL" (OBLIST .OBLIST))
+ <SET s <CHARSTREAM .s>>
+ <MAPF ,LIST <FUNCTION ("AUX" res)
+ <COND (<EMPTY? <1 .s>> <MAPSTOP>)
+ (ELSE <SET res <parse ,default .s>>
+ <COND (<==? .res EOF> <MAPSTOP>) (ELSE .res)>)>>>>
+
+;"Don't try to READ in objects of these types."
+<NEWTYPE closer FIX>
+<NEWTYPE prototemplate VECTOR>
+;"TODO: set appropriate ERROR as closer's EVALTYPE."
+
+<DEFINE bang (c) <+ .c #FIX %<LSH 1 21>>>
+<DEFINE banged? (c) <G=? .c #FIX %<LSH 1 21>>>
+<DEFINE unbang (c) <- .c #FIX %<LSH 1 21>>>
+<DEFINE explode-bang (c)
+ <COND (<banged? .c> <STRING %<1 "!"> <CHTYPE .c CHARACTER>>) (ELSE <CHTYPE .c CHARACTER>)>>
+
+;"Create the appropriate ERROR if there's a brace mismatch."
+;"Otherwise do nothing. Return value is ignored."
+<DEFINE check-closer (pos c opener s "TUPLE" closers)
+ <COND
+ (<TYPE? .c closer>
+ <COND
+ (<MEMQ <CHTYPE .c FIX> .closers>)
+ ;"TODO: position info"
+ (ELSE <ERROR BRACE-MISMATCH (POS .pos
+ OPENER <explode-bang .opener>
+ EXPECTED <MAPF ,LIST ,explode-bang .closers>
+ FOUND <explode-bang <CHTYPE .c FIX>>)>)>)
+ (<==? .c EOF> <ERROR UNCLOSED-BRACKET <explode-bang .opener> .pos>)>>
+
+;"TODO: accept radix in PARSE"
+<SETG radix 10>
+
+;"Create a standard Muddle CHARTABLE."
+<DEFINE make-default ("AUX" (t <CHARTABLE>))
+ <BULK-UPDATE .t
+ <SET-SPECIAL .t 9 T <FUNCTION (t s a) <AGAIN .a>>> ;"HT"
+ <SET-SPECIAL .t 10 T <FUNCTION (t s a) <NEWLINE-POS .s> <AGAIN .a>>> ;"LF"
+ <SET-SPECIAL .t 11 T <FUNCTION (t s a) <AGAIN .a>>> ;"VT"
+ <SET-SPECIAL .t 12 T <FUNCTION (t s a) <AGAIN .a>>> ;"FF"
+ <SET-SPECIAL .t 13 T <FUNCTION (t s a) <AGAIN .a>>> ;"CR"
+ <SET-SPECIAL .t 32 T <FUNCTION (t s a) <AGAIN .a>>> ;"space"
+ <SET-SPECIAL .t <ASCII !\.> <> <FUNCTION (t s a) <FORM LVAL <parse .t .s>>>>
+ <SET-SPECIAL .t <ASCII !\,> T <FUNCTION (t s a) <FORM GVAL <parse .t .s>>>>
+ <SET-SPECIAL .t <bang <ASCII !\.>> <> <FUNCTION (t s a) <CHTYPE <FORM LVAL <parse .t .s>> SEGMENT>>>
+ <SET-SPECIAL .t <bang <ASCII !\,>> T <FUNCTION (t s a) <CHTYPE <FORM GVAL <parse .t .s>> SEGMENT>>>
+ <SET-SPECIAL .t <ASCII !\'> T <FUNCTION (t s a) <FORM QUOTE <parse .t .s>>>>
+ <SET-SPECIAL .t <ASCII !\;> T <FUNCTION (t s a) <parse .t .s> <AGAIN .a>>>
+ <SET-SPECIAL .t <ASCII !\%> T <FUNCTION (t s a)
+ <COND (<==? %<ASCII !\%> <PEEK-CHAR .s>> <EAT-CHAR .s> <EVAL <parse .t .s>> <AGAIN .a>)>
+ <EVAL <parse .t .s>>>>
+ <SET-SPECIAL .t <ASCII !\#> T <FUNCTION (t s a "AUX" (type <parse .t .s>)) <CHTYPE <parse .t .s> .type>>>
+ <SET-SPECIAL .t <bang <ASCII !\\>> T <FUNCTION (t s a) <NEXT-CHAR .s>>>
+ <SET-SPECIAL .t <ASCII !\*> <> <FUNCTION (t s a) <parse-octal .t .s .a>>>
+
+ <SET-SPECIAL .t <ASCII !\"> T <FUNCTION (t s a)
+ <MAPF ,STRING <FUNCTION ("AUX" (c <NEXT-CHAR .s>))
+ <COND (<==? .c %<ASCII !\\>> <MAPRET <CHTYPE <NEXT-CHAR .s> CHARACTER>>)
+ (<banged? .c> <MAPRET %<1 "!"> <CHTYPE <unbang .c> CHARACTER>>)
+ (<==? .c %<ASCII !\">> <MAPSTOP>)
+ (<==? .c 10> <NEWLINE-POS .s> <MAPRET <CHTYPE .c CHARACTER>>)
+ (ELSE <MAPRET <CHTYPE .c CHARACTER>>)>>>>>
+
+ ;"TODO: macros for reducing the redundancy of all these openers and closers."
+
+ ;"A closer is an illegal object for anything except the corresponding opener."
+ <SET-SPECIAL .t <ASCII !\>> T <FUNCTION (t s a) <CHTYPE <ASCII !\>> closer>>>
+ <SET-SPECIAL .t <ASCII !\)> T <FUNCTION (t s a) <CHTYPE <ASCII !\)> closer>>>
+ <SET-SPECIAL .t <ASCII !\]> T <FUNCTION (t s a) <CHTYPE <ASCII !\]> closer>>>
+ <SET-SPECIAL .t <ASCII !\}> T <FUNCTION (t s a) <CHTYPE <ASCII !\}> closer>>>
+ <SET-SPECIAL .t <bang <ASCII !\>>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\>>> closer>>>
+ <SET-SPECIAL .t <bang <ASCII !\)>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\)>> closer>>>
+ <SET-SPECIAL .t <bang <ASCII !\]>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\]>> closer>>>
+ <SET-SPECIAL .t <bang <ASCII !\}>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\}>> closer>>>
+
+ <SET-SPECIAL .t <ASCII !\(> T <FUNCTION (t s a "AUX" pos)
+ <SET pos <GET-POS .s>>
+ <MAPF ,LIST <FUNCTION ("AUX" (x <parse .t .s>))
+ <COND (<check-closer .x <ASCII !\(> .s <ASCII !\)>> <MAPSTOP>)
+ (ELSE <MAPRET .x>)>>>>>
+
+ <SET-SPECIAL .t <ASCII !\<> T <FUNCTION (t s a "AUX" pos)
+ <SET pos <GET-POS .s>>
+ <MAPF ,FORM <FUNCTION ("AUX" (x <parse .t .s>))
+ <COND (<check-closer .pos .x <ASCII !\<> .s <ASCII !\>>> <MAPSTOP>)
+ (ELSE <MAPRET .x>)>>>>>
+
+ <SET-SPECIAL .t <ASCII !\[> T <FUNCTION (t s a "AUX" pos)
+ <SET pos <GET-POS .s>>
+ <MAPF ,VECTOR <FUNCTION ("AUX" (x <parse .t .s>))
+ <COND (<check-closer .pos .x <ASCII !\[> .s <ASCII !\]>> <MAPSTOP>)
+ (ELSE <MAPRET .x>)>>>>>
+
+ <SET-SPECIAL .t <bang <ASCII !\[>> T <FUNCTION (t s a "AUX" pos)
+ <SET pos <GET-POS .s>>
+ <MAPF ,UVECTOR <FUNCTION ("AUX" (x <parse .t .s>))
+ <COND (<check-closer .pos .x <bang <ASCII !\[>> .s <ASCII !\]>> <bang <ASCII !\]>> <MAPSTOP>)
+ (ELSE <MAPRET .x>)>>>>>
+
+ <SET-SPECIAL .t <bang <ASCII !\<>> T <FUNCTION (t s a "AUX" pos)
+ <SET pos <GET-POS .s>>
+ <CHTYPE <MAPF ,FORM <FUNCTION ("AUX" (x <parse .t .s>))
+ <COND (<check-closer .pos .x <bang <ASCII !\<>> .s <ASCII !\>>> <bang <ASCII !\>>> <MAPSTOP>)
+ (ELSE <MAPRET .x>)>>> SEGMENT>>>
+
+ ;"The prototemplate returned is an illegal object for anything except #-syntax."
+ <SET-SPECIAL .t <ASCII !\{> T <FUNCTION (t s a "AUX" pos)
+ <SET pos <GET-POS .s>>
+ <CHTYPE <MAPF ,VECTOR <FUNCTION ("AUX" (x <parse .t .s>))
+ <COND (<check-closer .pos .x <ASCII !\{> .s <ASCII !\}>> <MAPSTOP>)
+ (ELSE <MAPRET .x>)>>> prototemplate>>>
+
+ ;"Plain backslash just gets default handling in the lexer. It's only
+ special to the scalar sublexer."
+
+ <SET-DEFAULT .t ,parse-scalar>>>
+
+;"Lookup a string in an OBLIST / OBLIST list. If it isn't found,
+ insert it into the OBLIST / head of the OBLIST list."
+<DEFINE lookup-multi (a os)
+ <COND (<TYPE? .os OBLIST> <OR <LOOKUP .a .os> <INSERT .a .os>>)
+ (ELSE <OR <MAPF <> <FUNCTION (o "AUX" (atm <LOOKUP .a .o>))
+ <COND (.atm <MAPLEAVE .atm>)>> .os>
+ <INSERT .a <1 .os>>>)>>
+
+;"TODO: BLOCK..."
+<DEFINE parse-atom (t s a "AUX" (atoms ()) atm pn is-trailed "NAME" getpn)
+ ;"Copy up to any trailer into a temporary STRING."
+ <SET is-trailed <>>
+ <SET pn <MAPF ,STRING <FUNCTION ("AUX" (k <PEEK-CHAR .s>))
+ <COND (<BREAKER? .t .k> <MAPSTOP>)
+ (<==? .k %<bang <ASCII !\->>> <SET is-trailed T> <EAT-CHAR .s> <MAPSTOP>)
+ (<banged? .k> <EAT-CHAR .s> <MAPRET %<1 "!"> <CHTYPE <unbang .k> CHARACTER>>)
+ (ELSE <EAT-CHAR .s> <MAPRET <CHTYPE .k CHARACTER>>)>>>>
+ ;"Gather trailer-separated PNAMEs into a stack."
+ <COND (.is-trailed <SET atoms (.pn !.atoms)> <AGAIN .getpn>)>
+ ;"Now we have a LIST of STRINGs containing our trailed PNAMEs, with
+ the last still in .pn. The final PNAME is special: because it has
+ no trailer, we look it up in our oblist list."
+ <COND
+ (<EMPTY? .pn> <ROOT>
+ ;"Special case: we have an OBLIST, not an ATOM identifying an OBLIST."
+ <SET atm <OR <LOOKUP <1 .atoms> .atm> <INSERT <1 .atoms> .atm>>>
+ <SET atoms <REST .atoms>>)
+ (ELSE <SET atm <lookup-multi .pn .OBLIST>>)>
+ <COND (<EMPTY? .atoms> <RETURN .atm .getpn>)>
+ ;"Lookup each atom in the oblist denoted the previous (trailer),"
+ ;"except the last, which is our ATOM."
+ <MAPF <>
+ <FUNCTION (x "AUX" ob)
+ <SET ob <MOBLIST .atm>>
+ <SET atm <OR <LOOKUP .x .ob> <INSERT .x .ob>>>>
+ .atoms>>
+
+<DEFINE parse-octal (t s a "AUX" (z <COPY-CHARSTREAM .s>) c (n 0) (havedigits <>) "NAME" oct)
+ <SET c <NEXT-CHAR .z>>
+ <COND
+ ;"Ended without a trailing *?"
+ (<BREAKER? .t .c> <RETURN-CHAR .s> <parse-atom .t .s .a>)
+ ;"Made it to *?"
+ (<==? .c %<ASCII !\*>>
+ <COND (.havedigits <SET-CHARSTREAM .s .z> <RETURN <CHTYPE .n FIX> .a>)
+ (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>)
+ ;"Got another octit?"
+ (<AND <L=? %<ASCII !\0> .c> <L=? .c %<ASCII !\9>>>
+ <SET n <ORB <- .c %<ASCII !\0>> <LSH .n 3>>>
+ <SET havedigits T>
+ <AGAIN .oct>)
+ ;"Not octal after all."
+ (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>>
+
+;"If current radix isn't 10, pre-scan to see whether there's a decimal point."
+<DEFINE num-rad (s)
+ <COND
+ (<==? ,radix 10> 10)
+ (ELSE
+ <REPEAT ((z <COPY-CHARSTREAM .s>) "NAME" rdx)
+ <SET c <NEXT-CHAR .z>>
+ <COND (<BREAKER? .t .c> <RETURN ,radix .rdx>)
+ ;"Docs aren't clear on exponent-notation fixes without decimal points."
+ ;"Decimal makes more sense..."
+ (<==? %<ASCII !\e> .c> <RETURN 10 .rdx>)
+ (<==? %<ASCII !\E> .c> <RETURN 10 .rdx>)
+ (<==? %<ASCII !\.> .c> <RETURN 10 .rdx>)>>)>>
+
+<DEFINE parse-decimal (t c s a "AUX" (havedigits <>) (n 0) (sgn 1) (z <COPY-CHARSTREAM .s>) (rad <num-rad .s>))
+ <COND (<==? .c %<ASCII !\->> <SET sgn -1>)
+ (ELSE <RETURN-CHAR .z> <SET havedigits T>)>
+ <REPEAT ("NAME" decimal)
+ <SET c <NEXT-CHAR .z>>
+ <COND
+ ;"Done?"
+ (<BREAKER? .t .c>
+ <COND (.havedigits <RETURN-CHAR .z> <SET-CHARSTREAM .s .z> <RETURN <* .n .sgn> .a>)
+ (ELSE <RETURN-CHAR .s> <RETURN <parse-atom .t .s .a> .a>)>)
+ ;"Got a digit?"
+ (<AND <L=? %<ASCII !\0> .c> <L? .c <+ %<ASCII !\0> .rad>>>
+ <SET n <+ <* .n .rad> <- .c %<ASCII !\0>>>>
+ <SET havedigits T>)
+ ;".?"
+ ;"[eE]?"
+ ;"Not a decimal."
+ (ELSE <RETURN-CHAR .s> <RETURN <parse-atom .t .s .a> .a>)>>>
+
+;"The Scalar Sublexer."
+;"Parse an object that begins with a non-special character: FIX/FLOAT/ATOM."
+<DEFINE parse-scalar (t c s a "AUX" rad)
+ <COND
+ (<OR <==? .c %<ASCII !\->> <AND <L=? %<ASCII !\0> .c> <L=? .c %<ASCII !\9>>>>
+ <parse-decimal .t .c .s .a>)
+ (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>>
+
+;"Fallback to use if PARSE-TABLE!- is empty and no argument is provided."
+<SETG default <make-default>>
+<DEFINE DEFAULT-TABLE () ,default>
+
+%<AND <ENDBLOCK> <>>
+
+;"Like MAPF ,AND with early termination."
+<DEFINE ALL? (fn "TUPLE" argses "NAME" all)
+ <MAPF <> <FUNCTION ("TUPLE" xs) <COND (<NOT <APPLY .fn !.xs>> <RETURN <> .all>)>> !.argses>
+ T>
+
+;"This belongs in a PRINT module. Here for testing."
+<DEFINE PPRINT (x "OPTIONAL" (lvl 0))
+ <COND
+ (<TYPE? .x LIST> <PRINC !\(> <PPRINT-SEQ .x <+ .lvl 1>> <PRINC !\)>)
+ (<AND <TYPE? .x FORM> <NOT <OR <EMPTY? .x> <==? <1 .x> LVAL> <==? <1 .x> GVAL>>>>
+ <PRINC !\<> <PPRINT-SEQ .x <+ .lvl 1>> <PRINC !\>>)
+ (ELSE <PRIN1 .x>)>>
+<DEFINE PPRINT-SEQ (x lvl)
+ <COND (<EMPTY? .x>)
+ ;"TODO: more aggressive single-lining"
+ (<ALL? <FUNCTION (y) <OR <NOT <TYPE? .y FORM LIST>>
+ <EMPTY? .y>
+ <==? <1 .y> LVAL>
+ <==? <1 .y> GVAL>>> .x>
+ <PRIN1 <1 .x>>
+ <MAPF <> <FUNCTION (y) <PRINC !\ > <PRIN1 .y>> <REST .x>>)
+ (ELSE
+ <PPRINT <1 .x> .lvl>
+ <MAPF <> <FUNCTION (y) <CRLF> <INDENT .lvl> <PPRINT .y .lvl>> <REST .x>>)>>
+<DEFINE INDENT (lvl) <PRINC <ISTRING .lvl !\ >>>
+
+<PROG ()
+ <SET sss <ISTRING 40000>>
+ <SET sss <SUBSTRUC .sss 0 <READSTRING .sss <OPEN "READB" "./chartable.mud">>>>
+ <PPRINT <read-all!-PARSER .sss>>
+ >
+
+<QUIT>
projects / muddle.git / commitdiff