diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index a5ea059dcf..1c3d7e2d55 100644 --- a/core/lexer/lexer.factor +++ b/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* ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4856951ea5..693a62ecb4 100644 --- a/core/parser/parser.factor +++ b/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 -words words.symbol ; +sequences sets slots source-files splitting syntax.modern +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 ? ) - ?scan-datum { +: (parse-until-step) ( accum end token -- accum ? ) + 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 ; diff --git a/core/syntax/modern/authors.txt b/core/syntax/modern/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/core/syntax/modern/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/core/syntax/modern/modern.factor b/core/syntax/modern/modern.factor new file mode 100644 index 0000000000..b3b8e48715 --- /dev/null +++ b/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 \ No newline at end of file