parser: Add ``tag'payload`` and ``tag: payload``

core/lexer/lexer.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators continuations io kernel
-kernel.private math math.parser namespaces sequences
+kernel.private math math.order math.parser namespaces sequences
 sequences.private source-files.errors splitting strings vectors ;
 IN: lexer
 
+
 TUPLE: lexer
 { text array }
 { line fixnum }
@@ -148,6 +149,33 @@ PREDICATE: unexpected-eof < unexpected got>> not ;
 
 : throw-unexpected-eof ( word -- * ) f unexpected ;
 
+: strict-single-quote? ( string -- ? )
+    "'" split1
+    [ [ char: ' swap member? not ] [ drop t ] bi and ]
+    [ [ length 0 > ] [ "'" tail? not ] bi and ] bi* and ;
+
+: strict-lower-colon? ( string -- ? )
+    [ char: \: = ] cut-tail
+    [
+        [ length 0 > ] [
+            [ [ char: a char: z between? ] [ "-" member? ] bi or ] all?
+        ] bi and ]
+    [ length 0 > ] bi* and ;
+
+: (strict-upper-colon?) ( string -- ? )
+    ! All chars must...
+    [
+        [
+            [ char: A char: Z between? ] [ "':-\\#" member? ] bi or
+        ] all?
+    ]
+    ! At least one char must...
+    [ [ [ char: A char: Z between? ] [ char: ' = ] bi or ] any? ] bi and ;
+
+: strict-upper-colon? ( string -- ? )
+    [ [ char: \: = ] all? ]
+    [ (strict-upper-colon?) ] bi or ;
+
 : scan-token ( -- str )
     ?scan-token [ "token" throw-unexpected-eof ] unless* ;
 

core/parser/parser.factor

@@ -3,8 +3,8 @@
 USING: accessors arrays classes combinators compiler.units
 continuations definitions effects io io.encodings.utf8 io.files
 kernel lexer math.parser namespaces parser.notes quotations
-sequences sets slots source-files vectors vocabs vocabs.parser
+sequences sets slots source-files splitting syntax.modern
-words words.symbol ;
+vectors vocabs vocabs.parser words words.symbol ;
 IN: parser
 
 : location ( -- loc )
@@ -117,8 +117,9 @@ ERROR: classoid-expected object ;
     scan-object \ f or
     dup classoid? [ classoid-expected ] unless ;
 
-: parse-until-step ( accum end -- accum ? )
+: (parse-until-step) ( accum end token -- accum ? )
-    ?scan-datum {
+    dup [ parse-datum ] when
+    {
         { [ 2dup eq? ] [ 2drop f ] }
         { [ dup not ] [ drop throw-unexpected-eof t ] }
         { [ dup delimiter? ] [ unexpected t ] }
@@ -126,6 +127,20 @@ ERROR: classoid-expected object ;
         [ pick push drop t ]
     } cond ;
 
+: parse-lower-colon2 ( accum obj -- accum )
+    [ char: \: = ] cut-tail length [ scan-object ] replicate 2array
+    handle-lower-colon suffix! ;
+
+: parse-single-quote ( accum obj -- accum )
+    "'" split1 2array handle-single-quote suffix! ;
+
+: parse-until-step ( accum end -- accum ? )
+    ?scan-token {
+        ! { [ dup strict-lower-colon? ] [ nip parse-lower-colon2 t ] }
+        ! { [ dup strict-single-quote? ] [ nip parse-single-quote t ] }
+        [ (parse-until-step) ]
+    } cond ;
+
 : (parse-until) ( accum end -- accum )
     [ parse-until-step ] keep swap [ (parse-until) ] [ drop ] if ;
 

core/syntax/modern/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

core/syntax/modern/modern.factor

@@ -0,0 +1,62 @@
+! Copyright (C) 2018 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators kernel namespaces sequences splitting
+strings strings.parser ;
+IN: syntax.modern
+
+INITIALIZED-SYMBOL: single-quote-definitions [ H{ } clone ]
+INITIALIZED-SYMBOL: lower-colon-definitions [ H{ } clone ]
+INITIALIZED-SYMBOL: upper-colon-definitions [ H{ } clone ]
+INITIALIZED-SYMBOL: double-quote-definitions [ H{ } clone ]
+INITIALIZED-SYMBOL: bracket-container-definitions [ H{ } clone ]
+INITIALIZED-SYMBOL: brace-container-definitions [ H{ } clone ]
+INITIALIZED-SYMBOL: paren-container-definitions [ H{ } clone ]
+
+: define-single-quote-word ( word def -- ) swap lower-colon-definitions get set-at ;
+: define-lower-colon-word ( word def -- ) swap lower-colon-definitions get set-at ;
+: define-upper-colon-word ( word def -- ) swap upper-colon-definitions get set-at ;
+: define-double-quote-word ( word def -- ) swap double-quote-definitions get set-at ;
+: define-bracket-container-word ( word def -- ) swap bracket-container-definitions get set-at ;
+: define-brace-container-word ( word def -- ) swap brace-container-definitions get set-at ;
+: define-paren-container-word ( word def -- ) swap paren-container-definitions get set-at ;
+
+GENERIC: lower-colon>object ( obj -- obj' )
+GENERIC: double-quote>object ( obj -- obj' )
+GENERIC: bracket-container>object ( obj -- obj' )
+GENERIC: brace-container>object ( obj -- obj' )
+GENERIC: paren-container>object ( obj -- obj' )
+
+![[
+    SYNTAX: LOWER-COLON:
+    scan-new-class
+    [ ]
+    [ tuple { "object" } define-tuple-class ]
+    [ '[ _ boa suffix! ] define-lower-colon-word ] tri ;
+]]
+
+
+ERROR: no-single-quote-word payload word ;
+: handle-single-quote ( pair -- obj )
+    first2 swap single-quote-definitions get ?at
+    [ execute( obj -- obj' ) ]
+    [ no-single-quote-word ] if ;
+
+: ch>object ( ch -- obj )
+    {
+        { [ dup length 1 = ] [ first ] }
+        { [ "\\" ?head ] [ next-escape >string "" assert= ] }
+        [ name>char-hook get ( name -- char ) call-effect ]
+    } cond ;
+
+\ ch>object "ch" single-quote-definitions get set-at
+
+
+
+ERROR: no-lower-colon-word payload word ;
+: handle-lower-colon ( pair -- obj )
+    first2 swap lower-colon-definitions get ?at
+    [ execute( obj -- obj' ) ]
+    [ no-lower-colon-word ] if ;
+
+: no-op ( obj -- obj' ) ;
+\ no-op "data-stack" lower-colon-definitions get set-at