--- /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."
+<>
projects / muddle.git / blobdiff