factor: fix minor syntax problems. add some commented out sequences code that i wish worked.
need to rename ?tail to ?trim-taillocals-and-roots
parent
6d47257a6a
commit
6308848d19
|
@ -544,6 +544,15 @@ PRIVATE>
|
||||||
[ drop first4-unsafe ]
|
[ drop first4-unsafe ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
|
! : ?head* ( seq n -- headseq ) from-end short head ;
|
||||||
|
! : ?tail* ( seq n -- tailseq ) from-end short tail ;
|
||||||
|
! : ?cut* ( seq n -- before after ) [ ?head* ] [ ?tail* ] 2bi ;
|
||||||
|
|
||||||
|
! : ?head-slice* ( seq n -- slice ) from-end ?head-slice ; inline
|
||||||
|
! : ?tail-slice* ( seq n -- slice ) from-end ?tail-slice ; inline
|
||||||
|
! : ?head*-as ( seq n exemplar -- seq' ) [ ?head-slice* ] [ like ] bi* ; inline
|
||||||
|
! : ?tail*-as ( seq n exemplar -- seq' ) [ ?tail-slice* ] [ like ] bi* ; inline
|
||||||
|
|
||||||
: cut-when ( ... seq quot: ( ... elt -- ... ? ) -- ... before after )
|
: cut-when ( ... seq quot: ( ... elt -- ... ? ) -- ... before after )
|
||||||
[ find drop ] 2keep drop swap
|
[ find drop ] 2keep drop swap
|
||||||
[ cut ] [ f over like ] if* ; inline
|
[ cut ] [ f over like ] if* ; inline
|
||||||
|
|
|
@ -38,19 +38,19 @@ PRIVATE<
|
||||||
|
|
||||||
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
|
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
|
||||||
|
|
||||||
: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
|
: (a,) ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
|
||||||
|
|
||||||
: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
|
: (,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: [a,b] ( a b -- range ) twiddle <range> ; inline
|
: [a,b] ( a b -- range ) twiddle <range> ; inline
|
||||||
|
|
||||||
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
|
: (a,b] ( a b -- range ) twiddle (a,) <range> ; inline
|
||||||
|
|
||||||
: [a,b) ( a b -- range ) twiddle ,b) <range> ; inline
|
: [a,b) ( a b -- range ) twiddle (,b) <range> ; inline
|
||||||
|
|
||||||
: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; inline
|
: (a,b) ( a b -- range ) twiddle (a,) (,b) <range> ; inline
|
||||||
|
|
||||||
: [0,b] ( b -- range ) 0 swap [a,b] ; inline
|
: [0,b] ( b -- range ) 0 swap [a,b] ; inline
|
||||||
|
|
||||||
|
|
|
@ -162,14 +162,15 @@ M: array collapse-decorators
|
||||||
drop f
|
drop f
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: delimiters-match? ( opening closing -- ? )
|
ERROR: no-start-delimiter lexer opening ;
|
||||||
[
|
:: delimiters-match? ( lexer opening closing -- ? )
|
||||||
1 cut* over empty? [
|
opening empty? [ lexer opening closing no-start-delimiter ] when
|
||||||
nip matching-delimiter-string 1array
|
|
||||||
] [
|
opening 1 cut* over empty? [
|
||||||
matching-delimiter-string [ append ] [ nip ] 2bi 2array
|
nip matching-delimiter-string 1array
|
||||||
] if
|
] [
|
||||||
] dip '[ _ sequence= ] any? ;
|
matching-delimiter-string [ append ] [ nip ] 2bi 2array
|
||||||
|
] if closing '[ _ sequence= ] any? ;
|
||||||
|
|
||||||
|
|
||||||
ERROR: whitespace-expected-after n string ch ;
|
ERROR: whitespace-expected-after n string ch ;
|
||||||
|
@ -423,7 +424,7 @@ ERROR: backslash-expects-whitespace slice ;
|
||||||
|
|
||||||
ERROR: mismatched-terminator lexer slice ;
|
ERROR: mismatched-terminator lexer slice ;
|
||||||
: read-terminator ( lexer slice -- slice )
|
: read-terminator ( lexer slice -- slice )
|
||||||
2dup [ peek-tag ] dip delimiters-match? [
|
2dup [ dup peek-tag ] dip delimiters-match? [
|
||||||
nip terminator-literal make-tag-class-literal
|
nip terminator-literal make-tag-class-literal
|
||||||
] [
|
] [
|
||||||
mismatched-terminator
|
mismatched-terminator
|
||||||
|
@ -483,21 +484,21 @@ MACRO: rules>call-lexer ( seq -- quot: ( lexer string -- literal ) )
|
||||||
|
|
||||||
CONSTANT: factor-lexing-rules {
|
CONSTANT: factor-lexing-rules {
|
||||||
T{ line-comment-lexer { generator read-exclamation } { delimiter char: \! } }
|
T{ line-comment-lexer { generator read-exclamation } { delimiter char: \! } }
|
||||||
T{ backtick-lexer { generator read-backtick } { delimiter char: ` } }
|
T{ backtick-lexer { generator read-backtick } { delimiter char: \` } }
|
||||||
T{ backslash-lexer { generator read-backslash } { delimiter char: \\ } }
|
T{ backslash-lexer { generator read-backslash } { delimiter char: \\ } }
|
||||||
T{ dquote-lexer { generator read-string } { delimiter char: \" } { escape char: \\ } }
|
T{ dquote-lexer { generator read-string } { delimiter char: \" } { escape char: \\ } }
|
||||||
T{ decorator-lexer { generator read-decorator } { delimiter char: @ } }
|
T{ decorator-lexer { generator read-decorator } { delimiter char: \@ } }
|
||||||
|
|
||||||
T{ colon-lexer { generator read-colon } { delimiter char: \: } }
|
T{ colon-lexer { generator read-colon } { delimiter char: \: } }
|
||||||
T{ less-than-lexer { generator read-less-than } { delimiter char: < } }
|
T{ less-than-lexer { generator read-less-than } { delimiter char: \< } }
|
||||||
T{ matched-lexer { generator read-bracket } { delimiter char: \[ } }
|
T{ matched-lexer { generator read-bracket } { delimiter char: \[ } }
|
||||||
T{ matched-lexer { generator read-brace } { delimiter char: \{ } }
|
T{ matched-lexer { generator read-brace } { delimiter char: \{ } }
|
||||||
T{ matched-lexer { generator read-paren } { delimiter char: \( } }
|
T{ matched-lexer { generator read-paren } { delimiter char: \( } }
|
||||||
|
|
||||||
T{ terminator-lexer { generator read-terminator } { delimiter char: ; } }
|
T{ terminator-lexer { generator read-terminator } { delimiter char: \; } }
|
||||||
T{ terminator-lexer { generator read-terminator } { delimiter char: ] } }
|
T{ terminator-lexer { generator read-terminator } { delimiter char: \] } }
|
||||||
T{ terminator-lexer { generator read-terminator } { delimiter char: } } }
|
T{ terminator-lexer { generator read-terminator } { delimiter char: \} } }
|
||||||
T{ terminator-lexer { generator read-terminator } { delimiter char: ) } }
|
T{ terminator-lexer { generator read-terminator } { delimiter char: \) } }
|
||||||
|
|
||||||
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter char: \s } }
|
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter char: \s } }
|
||||||
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter char: \r } }
|
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter char: \r } }
|
||||||
|
|
|
@ -64,7 +64,7 @@ name>char-hook [
|
||||||
|
|
||||||
: unicode-escape ( str -- ch str' )
|
: unicode-escape ( str -- ch str' )
|
||||||
"{" ?head-slice [
|
"{" ?head-slice [
|
||||||
char: } over index cut-slice [
|
char: \} over index cut-slice [
|
||||||
dup hex> [
|
dup hex> [
|
||||||
nip
|
nip
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -188,12 +188,12 @@ in: bootstrap.syntax
|
||||||
] define-core-syntax
|
] define-core-syntax
|
||||||
|
|
||||||
"DEFER:" [
|
"DEFER:" [
|
||||||
scan-token current-vocab create-word
|
scan-new-escaped
|
||||||
[ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
|
[ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
|
||||||
] define-core-syntax
|
] define-core-syntax
|
||||||
|
|
||||||
"defer:" [
|
"defer:" [
|
||||||
scan-token current-vocab create-word
|
scan-new-escaped
|
||||||
[ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
|
[ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
|
||||||
] define-core-syntax
|
] define-core-syntax
|
||||||
|
|
||||||
|
|
|
@ -134,7 +134,7 @@ FUNCTOR-SYNTAX: \ MACRO:
|
||||||
\ define-macro suffix! ;
|
\ define-macro suffix! ;
|
||||||
|
|
||||||
FUNCTOR-SYNTAX: inline [ last-word make-inline ] append! ;
|
FUNCTOR-SYNTAX: inline [ last-word make-inline ] append! ;
|
||||||
FUNCTOR-SYNTAX: @inline [ last-word make-inline ] append! ;
|
FUNCTOR-SYNTAX: \ @inline [ last-word make-inline ] append! ;
|
||||||
|
|
||||||
FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
|
FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
|
||||||
|
|
||||||
|
@ -154,7 +154,7 @@ SYNTAX: DEFINES-PRIVATE [ begin-private create-word-in end-private ] (INTERPOLAT
|
||||||
|
|
||||||
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
|
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
|
||||||
|
|
||||||
defer: FUNCTOR; delimiter
|
defer: \ FUNCTOR> delimiter
|
||||||
|
|
||||||
PRIVATE<
|
PRIVATE<
|
||||||
|
|
||||||
|
@ -185,4 +185,4 @@ PRIVATE<
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
SYNTAX: \ FUNCTOR: (FUNCTOR:) define-declared ;
|
SYNTAX: \ FUNCTOR< (FUNCTOR:) define-declared ;
|
||||||
|
|
|
@ -85,6 +85,6 @@ MACRO: interpolate-locals ( str -- quot )
|
||||||
: interpolate-locals>string ( str -- newstr )
|
: interpolate-locals>string ( str -- newstr )
|
||||||
[ interpolate-locals ] with-string-writer ; inline
|
[ interpolate-locals ] with-string-writer ; inline
|
||||||
|
|
||||||
SYNTAX: I[[
|
SYNTAX: \ I[[
|
||||||
"]]" parse-multiline-string
|
"]]" parse-multiline-string
|
||||||
interpolate-locals-quot append! ;
|
interpolate-locals-quot append! ;
|
||||||
|
|
|
@ -8,8 +8,8 @@ vocabs.prettyprint words ;
|
||||||
in: prettyprint
|
in: prettyprint
|
||||||
|
|
||||||
: with-use ( obj quot -- )
|
: with-use ( obj quot -- )
|
||||||
t make-pprint (pprint-manifest
|
t make-pprint pprint-manifest-begin
|
||||||
[ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
|
[ pprint-manifest-end ] [ [ drop nl ] unless-empty ] bi
|
||||||
do-pprint ; inline
|
do-pprint ; inline
|
||||||
|
|
||||||
: with-in ( obj quot -- )
|
: with-in ( obj quot -- )
|
||||||
|
|
|
@ -126,7 +126,7 @@ M: word declarations.
|
||||||
postpone\ flushable
|
postpone\ flushable
|
||||||
} [ declaration. ] with each ;
|
} [ declaration. ] with each ;
|
||||||
|
|
||||||
: pprint-; ( -- ) \ ; pprint-word ;
|
: pprint-semi ( -- ) \ ; pprint-word ;
|
||||||
|
|
||||||
M: object see*
|
M: object see*
|
||||||
[
|
[
|
||||||
|
@ -143,12 +143,12 @@ GENERIC: see-class* ( word -- ) ;
|
||||||
M: union-class see-class*
|
M: union-class see-class*
|
||||||
<colon \ UNION: pprint-word
|
<colon \ UNION: pprint-word
|
||||||
dup pprint-word
|
dup pprint-word
|
||||||
class-members pprint-elements pprint-; block> ;
|
class-members pprint-elements pprint-semi block> ;
|
||||||
|
|
||||||
M: intersection-class see-class*
|
M: intersection-class see-class*
|
||||||
<colon \ INTERSECTION: pprint-word
|
<colon \ INTERSECTION: pprint-word
|
||||||
dup pprint-word
|
dup pprint-word
|
||||||
class-participants pprint-elements pprint-; block> ;
|
class-participants pprint-elements pprint-semi block> ;
|
||||||
|
|
||||||
M: mixin-class see-class*
|
M: mixin-class see-class*
|
||||||
<block \ mixin: pprint-word
|
<block \ mixin: pprint-word
|
||||||
|
@ -165,7 +165,7 @@ M: predicate-class see-class*
|
||||||
dup superclass-of pprint-word
|
dup superclass-of pprint-word
|
||||||
<block
|
<block
|
||||||
"predicate-definition" word-prop pprint-elements
|
"predicate-definition" word-prop pprint-elements
|
||||||
pprint-; block> block> ;
|
pprint-semi block> block> ;
|
||||||
|
|
||||||
M: singleton-class see-class* ( class -- )
|
M: singleton-class see-class* ( class -- )
|
||||||
\ singleton: pprint-word pprint-word ;
|
\ singleton: pprint-word pprint-word ;
|
||||||
|
@ -211,7 +211,7 @@ M: tuple-class see-class*
|
||||||
{
|
{
|
||||||
[ pprint-word ]
|
[ pprint-word ]
|
||||||
[ superclass. ]
|
[ superclass. ]
|
||||||
[ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
|
[ <block "slots" word-prop [ pprint-slot ] each block> pprint-semi ]
|
||||||
[ tuple-declarations. ]
|
[ tuple-declarations. ]
|
||||||
} cleave
|
} cleave
|
||||||
block> ;
|
block> ;
|
||||||
|
@ -222,7 +222,7 @@ M: builtin-class see-class*
|
||||||
<block
|
<block
|
||||||
\ BUILTIN: pprint-word
|
\ BUILTIN: pprint-word
|
||||||
[ pprint-word ]
|
[ pprint-word ]
|
||||||
[ <block "slots" word-prop [ pprint-slot ] each pprint-; block> ] bi
|
[ <block "slots" word-prop [ pprint-slot ] each pprint-semi block> ] bi
|
||||||
block> ;
|
block> ;
|
||||||
|
|
||||||
: see-class ( class -- )
|
: see-class ( class -- )
|
||||||
|
@ -245,7 +245,7 @@ M: error-class see-class*
|
||||||
{
|
{
|
||||||
[ pprint-word ]
|
[ pprint-word ]
|
||||||
[ superclass. ]
|
[ superclass. ]
|
||||||
[ <block "slots" word-prop [ name>> pprint-slot-name ] each block> pprint-; ]
|
[ <block "slots" word-prop [ name>> pprint-slot-name ] each block> pprint-semi ]
|
||||||
[ tuple-declarations. ]
|
[ tuple-declarations. ]
|
||||||
} cleave
|
} cleave
|
||||||
block> ;
|
block> ;
|
||||||
|
|
|
@ -34,7 +34,7 @@ MACRO: write-tuple ( class -- quot )
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
FUNCTOR: define-tuple-array ( CLASS -- )
|
FUNCTOR< define-tuple-array ( CLASS -- )
|
||||||
|
|
||||||
CLASS IS ${CLASS}
|
CLASS IS ${CLASS}
|
||||||
|
|
||||||
|
@ -71,6 +71,6 @@ M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
|
||||||
|
|
||||||
INSTANCE: CLASS-array sequence ;
|
INSTANCE: CLASS-array sequence ;
|
||||||
|
|
||||||
FUNCTOR;
|
FUNCTOR>
|
||||||
|
|
||||||
SYNTAX: \ tuple-array: scan-word define-tuple-array ;
|
SYNTAX: \ tuple-array: scan-word define-tuple-array ;
|
||||||
|
|
|
@ -68,7 +68,7 @@ M: rename pprint-qualified ( rename -- )
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: (pprint-manifest ( manifest -- quots )
|
: pprint-manifest-begin ( manifest -- quots )
|
||||||
[
|
[
|
||||||
[ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
|
[ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
|
||||||
[ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
|
[ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
|
||||||
|
@ -76,11 +76,11 @@ PRIVATE>
|
||||||
tri
|
tri
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
: pprint-manifest) ( quots -- )
|
: pprint-manifest-end ( quots -- )
|
||||||
[ nl ] [ call( -- ) ] interleave ;
|
[ nl ] [ call( -- ) ] interleave ;
|
||||||
|
|
||||||
: pprint-manifest ( manifest -- )
|
: pprint-manifest ( manifest -- )
|
||||||
(pprint-manifest pprint-manifest) ;
|
pprint-manifest-begin pprint-manifest-end ;
|
||||||
|
|
||||||
CONSTANT: manifest-style H{
|
CONSTANT: manifest-style H{
|
||||||
{ page-color color: FactorLightTan }
|
{ page-color color: FactorLightTan }
|
||||||
|
|
Loading…
Reference in New Issue