Refactor the lexer/parser to expose friendlier words for scanning tokens. The preferred top-level words now throw an exception on EOF.
CREATE -> scan-new CREATE-CLASS -> scan-new-class CREATE-WORD -> scan-new-word CREATE-GENERIC -> scan-new-generic scan -> (scan-token) scan-token now throws on eof (scan-word) returns word/number/f scan-word now throws on eof scan-word-name expects a non-number Fixes #183. Fixes #209.db4
parent
6c775cb489
commit
76580da5d5
|
@ -18,7 +18,7 @@ ERROR: bad-array-type ;
|
|||
|
||||
: parse-array-type ( name -- c-type )
|
||||
"[" split unclip
|
||||
[ [ "]" ?tail [ bad-array-type ] unless parse-word ] map ]
|
||||
[ [ "]" ?tail [ bad-array-type ] unless parse-word/number ] map ]
|
||||
[ (parse-c-type) ]
|
||||
bi* prefix ;
|
||||
|
||||
|
@ -70,7 +70,7 @@ ERROR: *-in-c-type-name name ;
|
|||
} cleave ;
|
||||
|
||||
: CREATE-C-TYPE ( -- word )
|
||||
scan (CREATE-C-TYPE) ;
|
||||
(scan-token) (CREATE-C-TYPE) ;
|
||||
|
||||
<PRIVATE
|
||||
GENERIC: return-type-name ( type -- name )
|
||||
|
@ -88,21 +88,21 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
|
|||
[ [ 2array suffix! ] [ enum>number 1 + ] bi ] 2bi ;
|
||||
|
||||
: parse-enum-name ( -- name )
|
||||
scan (CREATE-C-TYPE) dup save-location ;
|
||||
(scan-token) (CREATE-C-TYPE) dup save-location ;
|
||||
|
||||
: parse-enum-base-type ( -- base-type token )
|
||||
scan dup "<" =
|
||||
[ drop scan-object scan ]
|
||||
(scan-token) dup "<" =
|
||||
[ drop scan-object (scan-token) ]
|
||||
[ [ int ] dip ] if ;
|
||||
|
||||
: parse-enum-member ( members name value -- members value' )
|
||||
over "{" =
|
||||
[ 2drop scan create-class-in scan-object next-enum-member "}" expect ]
|
||||
[ 2drop (scan-token) create-class-in scan-object next-enum-member "}" expect ]
|
||||
[ [ create-class-in ] dip next-enum-member ] if ;
|
||||
|
||||
: parse-enum-members ( members counter token -- members )
|
||||
dup ";" = not
|
||||
[ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ;
|
||||
[ swap parse-enum-member (scan-token) parse-enum-members ] [ 2drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -112,14 +112,14 @@ PRIVATE>
|
|||
[ V{ } clone 0 ] dip parse-enum-members ;
|
||||
|
||||
: scan-function-name ( -- return function )
|
||||
scan-c-type scan parse-pointers ;
|
||||
scan-c-type (scan-token) parse-pointers ;
|
||||
|
||||
:: (scan-c-args) ( end-marker types names -- )
|
||||
scan :> type-str
|
||||
(scan-token) :> type-str
|
||||
type-str end-marker = [
|
||||
type-str { "(" ")" } member? [
|
||||
type-str parse-c-type :> type
|
||||
scan "," ?tail drop :> name
|
||||
(scan-token) "," ?tail drop :> name
|
||||
type name parse-pointers :> ( type' name' )
|
||||
type' types push name' names push
|
||||
] unless
|
||||
|
|
|
@ -13,7 +13,7 @@ SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
|
|||
|
||||
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
|
||||
|
||||
SYNTAX: LIBRARY: scan current-library set ;
|
||||
SYNTAX: LIBRARY: scan-token current-library set ;
|
||||
|
||||
SYNTAX: FUNCTION:
|
||||
(FUNCTION:) make-function define-inline ;
|
||||
|
@ -35,9 +35,9 @@ SYNTAX: C-TYPE:
|
|||
void CREATE-C-TYPE typedef ;
|
||||
|
||||
SYNTAX: &:
|
||||
scan current-library get '[ _ _ address-of ] append! ;
|
||||
scan-token current-library get '[ _ _ address-of ] append! ;
|
||||
|
||||
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
|
||||
SYNTAX: C-GLOBAL: scan-c-type scan-new-word define-global ;
|
||||
|
||||
SYNTAX: pointer:
|
||||
scan-c-type <pointer> suffix! ;
|
||||
|
|
|
@ -8,7 +8,7 @@ SYMBOL: special-objects
|
|||
SYNTAX: RESET H{ } clone special-objects set-global ;
|
||||
|
||||
SYNTAX: SPECIAL-OBJECT:
|
||||
CREATE-WORD scan-word
|
||||
scan-new-word scan-word
|
||||
[ swap special-objects get set-at ]
|
||||
[ drop define-symbol ]
|
||||
2bi ;
|
|
@ -354,7 +354,7 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
: parse-struct-slot ( -- slot )
|
||||
scan scan-c-type \ } parse-until <struct-slot-spec> ;
|
||||
(scan-token) scan-c-type \ } parse-until <struct-slot-spec> ;
|
||||
|
||||
: parse-struct-slots ( slots -- slots' more? )
|
||||
scan-token {
|
||||
|
@ -364,7 +364,7 @@ PRIVATE>
|
|||
} case ;
|
||||
|
||||
: parse-struct-definition ( -- class slots )
|
||||
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
|
||||
scan-new-class 8 <vector> [ parse-struct-slots ] [ ] while >array
|
||||
dup [ name>> ] map check-duplicate-slots ;
|
||||
PRIVATE>
|
||||
|
||||
|
@ -387,14 +387,14 @@ SYNTAX: S@
|
|||
|
||||
<PRIVATE
|
||||
: scan-c-type` ( -- c-type/param )
|
||||
scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
|
||||
(scan-token) dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
|
||||
|
||||
: parse-struct-slot` ( accum -- accum )
|
||||
scan-string-param scan-c-type` \ } parse-until
|
||||
[ <struct-slot-spec> suffix! ] 3curry append! ;
|
||||
|
||||
: parse-struct-slots` ( accum -- accum more? )
|
||||
scan {
|
||||
(scan-token) {
|
||||
{ ";" [ f ] }
|
||||
{ "{" [ parse-struct-slot` t ] }
|
||||
[ invalid-struct-slot ]
|
||||
|
|
|
@ -14,14 +14,14 @@ SYMBOL: sent-messages
|
|||
: remember-send ( selector -- )
|
||||
sent-messages (remember-send) ;
|
||||
|
||||
SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;
|
||||
SYNTAX: -> scan-token dup remember-send suffix! \ send suffix! ;
|
||||
|
||||
SYMBOL: super-sent-messages
|
||||
|
||||
: remember-super-send ( selector -- )
|
||||
super-sent-messages (remember-send) ;
|
||||
|
||||
SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ;
|
||||
SYNTAX: SUPER-> scan-token dup remember-super-send suffix! \ super-send suffix! ;
|
||||
|
||||
SYMBOL: frameworks
|
||||
|
||||
|
@ -29,9 +29,9 @@ frameworks [ V{ } clone ] initialize
|
|||
|
||||
[ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook
|
||||
|
||||
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
|
||||
SYNTAX: FRAMEWORK: scan-token [ load-framework ] [ frameworks get push ] bi ;
|
||||
|
||||
SYNTAX: IMPORT: scan [ ] import-objc-class ;
|
||||
SYNTAX: IMPORT: scan-token [ ] import-objc-class ;
|
||||
|
||||
"Importing Cocoa classes..." print
|
||||
|
||||
|
|
|
@ -30,4 +30,4 @@ ERROR: no-such-color name ;
|
|||
: named-color ( name -- color )
|
||||
dup colors at [ ] [ no-such-color ] ?if ;
|
||||
|
||||
SYNTAX: COLOR: scan named-color suffix! ;
|
||||
SYNTAX: COLOR: scan-token named-color suffix! ;
|
||||
|
|
|
@ -13,4 +13,4 @@ IN: colors.hex
|
|||
[ red>> ] [ green>> ] [ blue>> ] tri
|
||||
[ 255 * >integer ] tri@ "%02X%02X%02X" sprintf ;
|
||||
|
||||
SYNTAX: HEXCOLOR: scan hex>rgba suffix! ;
|
||||
SYNTAX: HEXCOLOR: scan-token hex>rgba suffix! ;
|
||||
|
|
|
@ -133,7 +133,7 @@ INSTANCE: name-analysis backward-analysis
|
|||
PRIVATE>
|
||||
|
||||
SYNTAX: FORWARD-ANALYSIS:
|
||||
scan [ define-analysis ] [ define-forward-analysis ] bi ;
|
||||
scan-token [ define-analysis ] [ define-forward-analysis ] bi ;
|
||||
|
||||
SYNTAX: BACKWARD-ANALYSIS:
|
||||
scan [ define-analysis ] [ define-backward-analysis ] bi ;
|
||||
scan-token [ define-analysis ] [ define-backward-analysis ] bi ;
|
||||
|
|
|
@ -86,13 +86,13 @@ TUPLE: insn-slot-spec type name rep ;
|
|||
} 3cleave ;
|
||||
|
||||
SYNTAX: INSN:
|
||||
CREATE-CLASS insn-word ";" parse-tokens define-insn ;
|
||||
scan-new-class insn-word ";" parse-tokens define-insn ;
|
||||
|
||||
SYNTAX: VREG-INSN:
|
||||
CREATE-CLASS vreg-insn-word ";" parse-tokens define-insn ;
|
||||
scan-new-class vreg-insn-word ";" parse-tokens define-insn ;
|
||||
|
||||
SYNTAX: FLUSHABLE-INSN:
|
||||
CREATE-CLASS flushable-insn-word ";" parse-tokens define-insn ;
|
||||
scan-new-class flushable-insn-word ";" parse-tokens define-insn ;
|
||||
|
||||
SYNTAX: FOLDABLE-INSN:
|
||||
CREATE-CLASS foldable-insn-word ";" parse-tokens define-insn ;
|
||||
scan-new-class foldable-insn-word ";" parse-tokens define-insn ;
|
||||
|
|
|
@ -74,4 +74,4 @@ insn-classes get [ insn-temp-slots empty? not ] filter [
|
|||
|
||||
;FUNCTOR
|
||||
|
||||
SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ;
|
||||
SYNTAX: RENAMING: scan-token scan-object scan-object scan-object define-renaming ;
|
||||
|
|
|
@ -97,6 +97,6 @@ FUNCTION: CFStringRef CFCopyTypeIDDescription ( CFTypeID type_id ) ;
|
|||
CFGetTypeID [ CFCopyTypeIDDescription &CFRelease CF>string ] with-destructors ;
|
||||
|
||||
SYNTAX: CFSTRING:
|
||||
CREATE scan-object
|
||||
scan-new-word scan-object
|
||||
[ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
|
||||
(( -- alien )) define-declared ;
|
||||
|
|
|
@ -24,7 +24,7 @@ icons [ H{ } clone ] initialize
|
|||
define
|
||||
] 2bi ;
|
||||
|
||||
SYNTAX: ICON: scan-word scan define-icon ;
|
||||
SYNTAX: ICON: scan-word scan-token define-icon ;
|
||||
|
||||
>>
|
||||
|
||||
|
|
|
@ -166,7 +166,7 @@ PRIVATE>
|
|||
] 2bi ;
|
||||
|
||||
SYNTAX: PROTOCOL:
|
||||
CREATE-WORD parse-definition define-protocol ;
|
||||
scan-new-word parse-definition define-protocol ;
|
||||
|
||||
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
|
||||
|
||||
|
@ -181,6 +181,6 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
|
|||
M: protocol group-words protocol-words ;
|
||||
|
||||
SYNTAX: SLOT-PROTOCOL:
|
||||
CREATE-WORD ";"
|
||||
scan-new-word ";"
|
||||
[ [ reader-word ] [ writer-word ] bi 2array ]
|
||||
map-tokens concat define-protocol ;
|
||||
|
|
|
@ -23,7 +23,7 @@ SYNTAX: FUNCTOR-SYNTAX:
|
|||
scan-token >string-param ;
|
||||
|
||||
: scan-c-type-param ( -- c-type/param )
|
||||
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
|
||||
(scan-token) dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
|
||||
|
||||
: define* ( word def -- ) over set-word define ;
|
||||
|
||||
|
|
|
@ -52,7 +52,7 @@ M: object (fake-quotations>) , ;
|
|||
|
||||
FUNCTOR-SYNTAX: TUPLE:
|
||||
scan-param suffix!
|
||||
scan {
|
||||
(scan-token) {
|
||||
{ ";" [ tuple suffix! f suffix! ] }
|
||||
{ "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] }
|
||||
[
|
||||
|
@ -122,7 +122,7 @@ FUNCTOR-SYNTAX: inline [ word make-inline ] append! ;
|
|||
FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
|
||||
|
||||
: (INTERPOLATE) ( accum quot -- accum )
|
||||
[ scan interpolate-locals ] dip
|
||||
[ (scan-token) interpolate-locals ] dip
|
||||
'[ _ with-string-writer @ ] suffix! ;
|
||||
|
||||
PRIVATE>
|
||||
|
@ -175,7 +175,7 @@ DEFER: ;FUNCTOR delimiter
|
|||
pop-functor-words ;
|
||||
|
||||
: (FUNCTOR:) ( -- word def effect )
|
||||
CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
|
||||
scan-new-word [ parse-functor-body ] parse-locals-definition ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -54,7 +54,7 @@ M: gir-not-found summary
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: GIR: scan define-gir-vocab ;
|
||||
SYNTAX: GIR: scan-token define-gir-vocab ;
|
||||
|
||||
SYNTAX: IMPLEMENT-STRUCTS:
|
||||
";" parse-tokens
|
||||
|
|
|
@ -14,7 +14,7 @@ tags [ H{ } clone ] initialize
|
|||
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
|
||||
|
||||
SYNTAX: CHLOE:
|
||||
scan parse-definition define-chloe-tag ;
|
||||
scan-token parse-definition define-chloe-tag ;
|
||||
|
||||
CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0"
|
||||
|
||||
|
|
|
@ -54,4 +54,4 @@ M: 8-bit-encoding <decoder>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: 8-BIT: scan scan scan load-encoding ;
|
||||
SYNTAX: 8-BIT: scan-token scan-token scan-token load-encoding ;
|
||||
|
|
|
@ -65,4 +65,4 @@ PRIVATE>
|
|||
|
||||
SYNTAX: EUC:
|
||||
! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
|
||||
CREATE-CLASS scan-object define-euc ;
|
||||
scan-new-class scan-object define-euc ;
|
||||
|
|
|
@ -6,7 +6,7 @@ locals.errors ;
|
|||
IN: locals
|
||||
|
||||
SYNTAX: :>
|
||||
scan locals get [ :>-outside-lambda-error ] unless*
|
||||
scan-token locals get [ :>-outside-lambda-error ] unless*
|
||||
parse-def suffix! ;
|
||||
|
||||
SYNTAX: [| parse-lambda append! ;
|
||||
|
|
|
@ -76,12 +76,12 @@ M: lambda-parser parse-quotation ( -- quotation )
|
|||
[ drop nip ] 3tri ; inline
|
||||
|
||||
: (::) ( -- word def effect )
|
||||
CREATE-WORD
|
||||
scan-new-word
|
||||
[ parse-definition ]
|
||||
parse-locals-definition ;
|
||||
|
||||
: (M::) ( -- word def )
|
||||
CREATE-METHOD
|
||||
scan-new-method
|
||||
[
|
||||
[ parse-definition ]
|
||||
parse-locals-definition drop
|
||||
|
|
|
@ -138,7 +138,7 @@ PRIVATE>
|
|||
|
||||
SYNTAX: LOG:
|
||||
#! Syntax: name level
|
||||
CREATE-WORD dup scan-word
|
||||
scan-new-word dup scan-word
|
||||
'[ 1array stack>message _ _ log-message ]
|
||||
(( message -- )) define-declared ;
|
||||
|
||||
|
|
|
@ -79,7 +79,7 @@ SYNTAX: A{ \ } [ >A ] parse-literal ;
|
|||
[ create-in (define-simd-128-cord) ] 2bi ;
|
||||
|
||||
SYNTAX: SIMD-128-CORD:
|
||||
scan-word scan define-simd-128-cord ;
|
||||
scan-word scan-token define-simd-128-cord ;
|
||||
|
||||
PRIVATE>
|
||||
>>
|
||||
|
|
|
@ -309,7 +309,7 @@ c:<c-type>
|
|||
;FUNCTOR
|
||||
|
||||
SYNTAX: SIMD-128:
|
||||
scan define-simd-128 ;
|
||||
scan-token define-simd-128 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -32,7 +32,7 @@ ERROR: text-found-before-eol string ;
|
|||
] "" make but-last ;
|
||||
|
||||
SYNTAX: STRING:
|
||||
CREATE-WORD
|
||||
scan-new-word
|
||||
parse-here 1quotation
|
||||
(( -- string )) define-inline ;
|
||||
|
||||
|
|
|
@ -280,7 +280,7 @@ H{ } clone verify-messages set-global
|
|||
: verify-message ( n -- word ) verify-messages get-global at ;
|
||||
|
||||
SYNTAX: X509_V_:
|
||||
scan "X509_V_" prepend create-in
|
||||
scan-token "X509_V_" prepend create-in
|
||||
scan-word
|
||||
[ 1quotation (( -- value )) define-inline ]
|
||||
[ verify-messages get set-at ]
|
||||
|
|
|
@ -49,7 +49,7 @@ M: no-tokenizer summary
|
|||
drop "Tokenizer not found" ;
|
||||
|
||||
SYNTAX: TOKENIZER:
|
||||
scan dup search [ nip ] [ no-tokenizer ] if*
|
||||
scan-word-name dup search [ nip ] [ no-tokenizer ] if*
|
||||
execute( -- tokenizer ) \ tokenizer set-global ;
|
||||
|
||||
TUPLE: ebnf-non-terminal symbol ;
|
||||
|
@ -570,7 +570,7 @@ SYNTAX: [EBNF
|
|||
suffix! \ call suffix! reset-tokenizer ;
|
||||
|
||||
SYNTAX: EBNF:
|
||||
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
|
||||
reset-tokenizer scan-new-word dup ";EBNF" parse-multiline-string
|
||||
ebnf>quot swapd
|
||||
(( input -- ast )) define-declared "ebnf-parser" set-word-prop
|
||||
reset-tokenizer ;
|
||||
|
|
|
@ -69,4 +69,4 @@ ROMAN-OP: * ( x y -- z )
|
|||
ROMAN-OP: /i ( x y -- z )
|
||||
ROMAN-OP: /mod ( x y -- z w )
|
||||
|
||||
SYNTAX: ROMAN: scan roman> suffix! ;
|
||||
SYNTAX: ROMAN: scan-token roman> suffix! ;
|
||||
|
|
|
@ -104,7 +104,7 @@ MACRO: <experiment> ( word -- )
|
|||
<<
|
||||
|
||||
SYNTAX: TEST:
|
||||
scan
|
||||
scan-token
|
||||
[ create-in ]
|
||||
[ "(" ")" surround search '[ _ parse-test ] ] bi
|
||||
define-syntax ;
|
||||
|
|
|
@ -41,7 +41,7 @@ M: bad-tr summary
|
|||
PRIVATE>
|
||||
|
||||
SYNTAX: TR:
|
||||
scan parse-definition
|
||||
scan-token parse-definition
|
||||
unclip-last [ unclip-last ] dip compute-tr
|
||||
[ check-tr ]
|
||||
[ [ create-tr ] dip define-tr ]
|
||||
|
|
|
@ -87,7 +87,7 @@ M: pixel-format-attribute >PFA
|
|||
;FUNCTOR
|
||||
|
||||
SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE:
|
||||
scan scan-object scan-object define-pixel-format-attribute-table ;
|
||||
scan-token scan-object scan-object define-pixel-format-attribute-table ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -226,7 +226,7 @@ HOOK: system-alert ui-backend ( caption text -- )
|
|||
] [ 2drop current-vocab main<< ] 3bi ;
|
||||
|
||||
SYNTAX: MAIN-WINDOW:
|
||||
CREATE
|
||||
scan-new-word
|
||||
world-attributes parse-main-window-attributes
|
||||
parse-definition
|
||||
define-main-window ;
|
||||
|
|
|
@ -23,7 +23,7 @@ SYMBOLS: Cn Lu Ll Lt Lm Lo Mn Mc Me Nd Nl No Pc Pd Ps Pe Pi Pf Po Sm Sc Sk So Zs
|
|||
[category] [ not ] compose integer-predicate-class ;
|
||||
|
||||
: parse-category ( -- word tokens quot )
|
||||
CREATE-CLASS \ ; parse-until { | } split1
|
||||
scan-new-class \ ; parse-until { | } split1
|
||||
[ [ name>> categories-map at ] map ]
|
||||
[ [ [ ] like ] [ [ drop f ] ] if* ] bi* ;
|
||||
|
||||
|
|
|
@ -31,7 +31,7 @@ PREDICATE: value-word < word
|
|||
} 1&& ;
|
||||
|
||||
SYNTAX: VALUE:
|
||||
CREATE-WORD
|
||||
scan-new-word
|
||||
dup t "no-def-strip" set-word-prop
|
||||
T{ value-holder } clone [ obj>> ] curry
|
||||
(( -- value )) define-declared ;
|
||||
|
|
|
@ -43,8 +43,8 @@ ERROR: no-com-interface interface ;
|
|||
<com-function-definition> ;
|
||||
|
||||
:: (parse-com-functions) ( functions -- )
|
||||
scan dup ";" = [ drop ] [
|
||||
parse-c-type scan parse-pointers
|
||||
(scan-token) dup ";" = [ drop ] [
|
||||
parse-c-type (scan-token) parse-pointers
|
||||
(parse-com-function) functions push
|
||||
functions (parse-com-functions)
|
||||
] if ;
|
||||
|
@ -86,13 +86,13 @@ SYNTAX: COM-INTERFACE:
|
|||
CREATE-C-TYPE
|
||||
void* over typedef
|
||||
scan-object find-com-interface-definition
|
||||
scan string>guid
|
||||
scan-token string>guid
|
||||
parse-com-functions
|
||||
<com-interface-definition>
|
||||
dup save-com-interface-definition
|
||||
define-words-for-com-interface ;
|
||||
|
||||
SYNTAX: GUID: scan string>guid suffix! ;
|
||||
SYNTAX: GUID: scan-token string>guid suffix! ;
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
|
|
|
@ -28,16 +28,16 @@ M: no-tag summary
|
|||
PRIVATE>
|
||||
|
||||
SYNTAX: TAGS:
|
||||
CREATE-WORD complete-effect
|
||||
scan-new-word complete-effect
|
||||
[ drop H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ]
|
||||
2bi ;
|
||||
|
||||
SYNTAX: TAG:
|
||||
scan scan-word parse-definition define-tag ;
|
||||
scan-token scan-word parse-definition define-tag ;
|
||||
|
||||
SYNTAX: XML-NS:
|
||||
CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;
|
||||
scan-new-word scan-token '[ f swap _ <name> ] (( string -- name )) define-memoized ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
@ -11,7 +11,7 @@ IN: xmode.loader.syntax
|
|||
new swap init-from-tag swap add-rule ; inline
|
||||
|
||||
SYNTAX: RULE:
|
||||
scan scan-word scan-word [
|
||||
scan-token scan-word scan-word [
|
||||
[ parse-definition call( -- ) ] { } make
|
||||
swap [ (parse-rule-tag) ] 2curry
|
||||
] dip swap define-tag ;
|
||||
|
|
|
@ -12,5 +12,5 @@ IN: classes.parser
|
|||
dup save-class-location
|
||||
dup create-predicate-word save-location ;
|
||||
|
||||
: CREATE-CLASS ( -- word )
|
||||
scan create-class-in ;
|
||||
: scan-new-class ( -- word )
|
||||
scan-word-name create-class-in ;
|
||||
|
|
|
@ -31,7 +31,7 @@ ERROR: duplicate-slot-names names ;
|
|||
ERROR: invalid-slot-name name ;
|
||||
|
||||
: parse-long-slot-name ( -- spec )
|
||||
[ scan , \ } parse-until % ] { } make ;
|
||||
[ (scan-token) , \ } parse-until % ] { } make ;
|
||||
|
||||
: parse-slot-name-delim ( end-delim string/f -- ? )
|
||||
! Check for mistakes of this form:
|
||||
|
@ -55,8 +55,8 @@ ERROR: invalid-slot-name name ;
|
|||
";" parse-tuple-slots-delim ;
|
||||
|
||||
: parse-tuple-definition ( -- class superclass slots )
|
||||
CREATE-CLASS
|
||||
scan {
|
||||
scan-new-class
|
||||
scan-token {
|
||||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
|
||||
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
|
||||
|
@ -72,7 +72,7 @@ ERROR: bad-slot-name class slot ;
|
|||
2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
|
||||
|
||||
: parse-slot-value ( class slots -- )
|
||||
scan check-slot-name scan-object 2array , scan-token {
|
||||
(scan-token) check-slot-name scan-object 2array , scan-token {
|
||||
{ "}" [ ] }
|
||||
[ bad-literal-tuple ]
|
||||
} case ;
|
||||
|
|
|
@ -34,7 +34,7 @@ SYMBOL: effect-var
|
|||
PRIVATE>
|
||||
|
||||
: parse-effect-token ( first? var end -- var more? )
|
||||
scan {
|
||||
(scan-token) {
|
||||
{ [ end-token? ] [ drop nip f ] }
|
||||
{ [ effect-opener? ] [ bad-effect ] }
|
||||
{ [ effect-closer? ] [ stack-effect-omits-dashes ] }
|
||||
|
@ -58,6 +58,6 @@ PRIVATE>
|
|||
[ ")" parse-effect ] dip 2array append! ;
|
||||
|
||||
: (:) ( -- word def effect )
|
||||
CREATE-WORD
|
||||
scan-new-word
|
||||
complete-effect
|
||||
parse-definition swap ;
|
||||
|
|
|
@ -5,10 +5,10 @@ IN: generic.parser
|
|||
|
||||
ERROR: not-in-a-method-error ;
|
||||
|
||||
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
|
||||
: scan-new-generic ( -- word ) scan-new dup reset-word ;
|
||||
|
||||
: (GENERIC:) ( quot -- )
|
||||
[ CREATE-GENERIC ] dip call complete-effect define-generic ; inline
|
||||
[ scan-new-generic ] dip call complete-effect define-generic ; inline
|
||||
|
||||
: create-method-in ( class generic -- method )
|
||||
create-method dup set-word dup save-location ;
|
||||
|
@ -16,7 +16,7 @@ ERROR: not-in-a-method-error ;
|
|||
: define-inline-method ( class generic quot -- )
|
||||
[ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
|
||||
|
||||
: CREATE-METHOD ( -- method )
|
||||
: scan-new-method ( -- method )
|
||||
scan-word bootstrap-word scan-word create-method-in ;
|
||||
|
||||
SYMBOL: current-method
|
||||
|
@ -25,5 +25,5 @@ SYMBOL: current-method
|
|||
over current-method set call current-method off ; inline
|
||||
|
||||
: (M:) ( -- method def )
|
||||
CREATE-METHOD [ parse-definition ] with-method-definition ;
|
||||
scan-new-method [ parse-definition ] with-method-definition ;
|
||||
|
||||
|
|
|
@ -57,14 +57,14 @@ HELP: parse-token
|
|||
{ $values { "lexer" lexer } { "str/f" { $maybe string } } }
|
||||
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
|
||||
|
||||
HELP: scan
|
||||
HELP: (scan-token)
|
||||
{ $values { "str/f" { $maybe string } } }
|
||||
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word outputs " { $link f } " on end of input. To throw an error on end of input, use " { $link scan-token } " instead." }
|
||||
$parsing-note ;
|
||||
|
||||
HELP: scan-token
|
||||
{ $values { "str" string } }
|
||||
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link scan } " instead." }
|
||||
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link (scan-token) } " instead." }
|
||||
$parsing-note ;
|
||||
|
||||
HELP: still-parsing?
|
||||
|
@ -102,7 +102,7 @@ HELP: unexpected-eof
|
|||
|
||||
HELP: with-lexer
|
||||
{ $values { "lexer" lexer } { "quot" quotation } { "newquot" quotation } }
|
||||
{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ;
|
||||
{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan-token } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ;
|
||||
|
||||
HELP: lexer-factory
|
||||
{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
|
||||
|
|
|
@ -84,13 +84,13 @@ M: lexer skip-word ( lexer -- )
|
|||
[ (parse-token) ] [ dup next-line parse-token ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: scan ( -- str/f ) lexer get parse-token ;
|
||||
: (scan-token) ( -- str/f ) lexer get parse-token ;
|
||||
|
||||
PREDICATE: unexpected-eof < unexpected got>> not ;
|
||||
|
||||
: unexpected-eof ( word -- * ) f unexpected ;
|
||||
|
||||
: scan-token ( -- str ) scan [ "token" unexpected-eof ] unless* ;
|
||||
: scan-token ( -- str ) (scan-token) [ "token" unexpected-eof ] unless* ;
|
||||
|
||||
: expect ( token -- )
|
||||
scan-token 2dup = [ 2drop ] [ unexpected ] if ;
|
||||
|
|
|
@ -9,12 +9,13 @@ ARTICLE: "reading-ahead" "Reading ahead"
|
|||
"Parsing words can consume input:"
|
||||
{ $subsections
|
||||
scan-token
|
||||
scan-word
|
||||
scan-object
|
||||
}
|
||||
"Lower-level words:"
|
||||
{ $subsections
|
||||
scan
|
||||
scan-word
|
||||
(scan-token)
|
||||
(scan-word)
|
||||
}
|
||||
"For example, the " { $link POSTPONE: HEX: } " word uses this feature to read hexadecimal literals:"
|
||||
{ $see POSTPONE: HEX: }
|
||||
|
@ -39,14 +40,14 @@ $nl
|
|||
ARTICLE: "defining-words" "Defining words"
|
||||
"Defining words add definitions to the dictionary without modifying the parse tree. The simplest example is the " { $link POSTPONE: SYMBOL: } " word."
|
||||
{ $see POSTPONE: SYMBOL: }
|
||||
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
|
||||
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link scan-new } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
|
||||
{ $subsections
|
||||
CREATE
|
||||
CREATE-WORD
|
||||
scan-new
|
||||
scan-new-word
|
||||
}
|
||||
"Colon definitions are defined in a more elaborate way:"
|
||||
{ $subsections POSTPONE: : }
|
||||
"The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
|
||||
"The " { $link POSTPONE: : } " word first calls " { $link scan-new } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
|
||||
{ $subsections parse-definition }
|
||||
"The " { $link POSTPONE: ; } " word is just a delimiter; an unpaired occurrence throws a parse error:"
|
||||
{ $see POSTPONE: ; }
|
||||
|
@ -129,7 +130,7 @@ HELP: create-in
|
|||
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
|
||||
$parsing-note ;
|
||||
|
||||
HELP: CREATE
|
||||
HELP: scan-new
|
||||
{ $values { "word" word } }
|
||||
{ $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." }
|
||||
{ $errors "Throws an error if the end of the line is reached." }
|
||||
|
@ -144,13 +145,19 @@ HELP: no-word
|
|||
{ $description "Throws a " { $link no-word-error } "." } ;
|
||||
|
||||
HELP: parse-word
|
||||
{ $values { "string" string } { "word/number" "a word or number" } }
|
||||
{ $values { "string" string } { "word" "a number" } }
|
||||
{ $description "If " { $snippet "string" } " is a valid number literal, it is converted to a number, otherwise the current vocabulary search path is searched for a word named by the string." }
|
||||
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
|
||||
{ $notes "This word is used to implement " { $link scan-word } "." } ;
|
||||
|
||||
HELP: parse-word/number
|
||||
{ $values { "string" string } { "word/number" "a word or number" } }
|
||||
{ $description "If " { $snippet "string" } " is a valid number literal, it is converted to a number, otherwise the current vocabulary search path is searched for a word named by the string." }
|
||||
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
|
||||
{ $notes "This word is used to implement " { $link (scan-word) } "." } ;
|
||||
|
||||
HELP: scan-word
|
||||
{ $values { "word/number/f" "a word, number or " { $link f } } }
|
||||
{ $values { "word/number" "a word or a number" } }
|
||||
{ $description "Reads the next token from parser input. If the token is a valid number literal, it is converted to a number, otherwise the vocabulary search path is searched for a word named by the token. Outputs " { $link f } " if the end of the input has been reached." }
|
||||
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
|
||||
$parsing-note ;
|
||||
|
|
|
@ -624,3 +624,13 @@ EXCLUDE: qualified.tests.bar => x ;
|
|||
[ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test
|
||||
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
|
||||
] with-file-vocabs
|
||||
|
||||
! Test cases for #183
|
||||
[ "SINGLETON: 33" <string-reader> "class identifier test" parse-stream ]
|
||||
[ error>> lexer-error? ] must-fail-with
|
||||
|
||||
[ ": 44 ( -- ) ;" <string-reader> "word identifier test" parse-stream ]
|
||||
[ error>> lexer-error? ] must-fail-with
|
||||
|
||||
[ "GENERIC: 33 ( -- )" <string-reader> "generic identifier test" parse-stream ]
|
||||
[ error>> lexer-error? ] must-fail-with
|
||||
|
|
|
@ -20,10 +20,6 @@ M: parsing-word stack-effect drop (( parsed -- parsed )) ;
|
|||
: create-in ( str -- word )
|
||||
current-vocab create dup set-word dup save-location ;
|
||||
|
||||
: CREATE ( -- word ) scan create-in ;
|
||||
|
||||
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
|
||||
|
||||
SYMBOL: auto-use?
|
||||
|
||||
: no-word-restarted ( restart-value -- word )
|
||||
|
@ -48,13 +44,31 @@ SYMBOL: auto-use?
|
|||
[ drop <no-word-error> throw-restarts no-word-restarted ]
|
||||
if ;
|
||||
|
||||
: parse-word ( string -- word/number )
|
||||
: parse-word ( string -- word )
|
||||
dup search [ ] [ no-word ] ?if ;
|
||||
|
||||
: parse-word/number ( string -- word/number )
|
||||
dup search [ ] [
|
||||
dup string>number [ ] [ no-word ] ?if
|
||||
] ?if ;
|
||||
|
||||
: scan-word ( -- word/number/f )
|
||||
scan dup [ parse-word ] when ;
|
||||
: (scan-word) ( -- word/number/f )
|
||||
(scan-token) dup [ parse-word/number ] when ;
|
||||
|
||||
: scan-word ( -- word/number )
|
||||
(scan-word) [ \ word unexpected-eof ] unless* ;
|
||||
|
||||
: scan-word-name ( -- string )
|
||||
scan-token
|
||||
dup string>number [
|
||||
"Word names cannot be numbers" throw
|
||||
] when ;
|
||||
|
||||
: scan-new ( -- word )
|
||||
scan-word-name create-in ;
|
||||
|
||||
: scan-new-word ( -- word )
|
||||
scan-new dup reset-generic ;
|
||||
|
||||
ERROR: staging-violation word ;
|
||||
|
||||
|
@ -68,14 +82,13 @@ ERROR: staging-violation word ;
|
|||
(execute-parsing) ;
|
||||
|
||||
: scan-object ( -- object )
|
||||
scan-word {
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup parsing-word? ] [ V{ } clone swap execute-parsing first ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
scan-word
|
||||
dup parsing-word? [
|
||||
V{ } clone swap execute-parsing first
|
||||
] when ;
|
||||
|
||||
: parse-step ( accum end -- accum ? )
|
||||
scan-word {
|
||||
(scan-word) {
|
||||
{ [ 2dup eq? ] [ 2drop f ] }
|
||||
{ [ dup not ] [ drop unexpected-eof t ] }
|
||||
{ [ dup delimiter? ] [ unexpected t ] }
|
||||
|
@ -110,7 +123,7 @@ M: f parse-quotation \ ] parse-until >quotation ;
|
|||
ERROR: bad-number ;
|
||||
|
||||
: scan-base ( base -- n )
|
||||
scan swap base> [ bad-number ] unless* ;
|
||||
scan-token swap base> [ bad-number ] unless* ;
|
||||
|
||||
: parse-base ( parsed base -- parsed )
|
||||
scan-base suffix! ;
|
||||
|
|
|
@ -117,11 +117,11 @@ IN: bootstrap.syntax
|
|||
"deprecated" [ word make-deprecated ] define-core-syntax
|
||||
|
||||
"SYNTAX:" [
|
||||
CREATE-WORD parse-definition define-syntax
|
||||
scan-new-word parse-definition define-syntax
|
||||
] define-core-syntax
|
||||
|
||||
"SYMBOL:" [
|
||||
CREATE-WORD define-symbol
|
||||
scan-new-word define-symbol
|
||||
] define-core-syntax
|
||||
|
||||
"SYMBOLS:" [
|
||||
|
@ -138,11 +138,11 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"ALIAS:" [
|
||||
CREATE-WORD scan-word define-alias
|
||||
scan-new-word scan-word define-alias
|
||||
] define-core-syntax
|
||||
|
||||
"CONSTANT:" [
|
||||
CREATE-WORD scan-object define-constant
|
||||
scan-new-word scan-object define-constant
|
||||
] define-core-syntax
|
||||
|
||||
":" [
|
||||
|
@ -170,15 +170,15 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"UNION:" [
|
||||
CREATE-CLASS parse-definition define-union-class
|
||||
scan-new-class parse-definition define-union-class
|
||||
] define-core-syntax
|
||||
|
||||
"INTERSECTION:" [
|
||||
CREATE-CLASS parse-definition define-intersection-class
|
||||
scan-new-class parse-definition define-intersection-class
|
||||
] define-core-syntax
|
||||
|
||||
"MIXIN:" [
|
||||
CREATE-CLASS define-mixin-class
|
||||
scan-new-class define-mixin-class
|
||||
] define-core-syntax
|
||||
|
||||
"INSTANCE:" [
|
||||
|
@ -189,14 +189,14 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"PREDICATE:" [
|
||||
CREATE-CLASS
|
||||
scan-new-class
|
||||
"<" expect
|
||||
scan-word
|
||||
parse-definition define-predicate-class
|
||||
] define-core-syntax
|
||||
|
||||
"SINGLETON:" [
|
||||
CREATE-CLASS define-singleton-class
|
||||
scan-new-class define-singleton-class
|
||||
] define-core-syntax
|
||||
|
||||
"TUPLE:" [
|
||||
|
@ -212,7 +212,7 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"C:" [
|
||||
CREATE-WORD scan-word define-boa-word
|
||||
scan-new-word scan-word define-boa-word
|
||||
] define-core-syntax
|
||||
|
||||
"ERROR:" [
|
||||
|
|
|
@ -8,7 +8,7 @@ SINGLETONS: all world commonwealth-of-nations ;
|
|||
|
||||
<<
|
||||
SYNTAX: HOLIDAY:
|
||||
CREATE-WORD
|
||||
scan-new-word
|
||||
dup "holiday" word-prop [
|
||||
dup H{ } clone "holiday" set-word-prop
|
||||
] unless
|
||||
|
|
|
@ -1397,10 +1397,10 @@ SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ;
|
|||
|
||||
SYNTAX: cycles
|
||||
#! Set the number of cycles for the last instruction that was defined.
|
||||
scan string>number last-opcode global at instruction-cycles set-nth ;
|
||||
scan-token string>number last-opcode global at instruction-cycles set-nth ;
|
||||
|
||||
SYNTAX: opcode ( -- )
|
||||
#! Set the opcode number for the last instruction that was defined.
|
||||
last-instruction global at 1quotation scan 16 base>
|
||||
last-instruction global at 1quotation scan-token 16 base>
|
||||
dup last-opcode global set-at set-instruction ;
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ SYMBOL: registers
|
|||
V{ } registers set-global
|
||||
|
||||
SYNTAX: REGISTER:
|
||||
CREATE-WORD
|
||||
scan-new-word
|
||||
[ define-symbol ]
|
||||
[ registers get length "register" set-word-prop ]
|
||||
[ registers get push ]
|
||||
|
|
|
@ -5,14 +5,14 @@ fry kernel lexer namespaces parser ;
|
|||
IN: cuda.syntax
|
||||
|
||||
SYNTAX: CUDA-LIBRARY:
|
||||
scan scan-word scan
|
||||
scan-token scan-word scan-token
|
||||
'[ _ _ add-cuda-library ]
|
||||
[ current-cuda-library set-global ] bi ;
|
||||
|
||||
SYNTAX: CUDA-FUNCTION:
|
||||
scan [ create-in current-cuda-library get ] keep
|
||||
scan-token [ create-in current-cuda-library get ] keep
|
||||
";" scan-c-args drop define-cuda-function ;
|
||||
|
||||
SYNTAX: CUDA-GLOBAL:
|
||||
scan [ create-in current-cuda-library get ] keep
|
||||
scan-token [ create-in current-cuda-library get ] keep
|
||||
define-cuda-global ;
|
||||
|
|
|
@ -18,7 +18,7 @@ TUPLE: decimal { mantissa read-only } { exponent read-only } ;
|
|||
[ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
|
||||
[ append string>number ] [ nip length neg ] 2bi <decimal> ;
|
||||
|
||||
: parse-decimal ( -- decimal ) scan string>decimal ;
|
||||
: parse-decimal ( -- decimal ) scan-token string>decimal ;
|
||||
|
||||
SYNTAX: D: parse-decimal suffix! ;
|
||||
|
||||
|
|
|
@ -82,7 +82,7 @@ M: game-world apply-world-attributes
|
|||
[ name>> "-attributes" append create-in ] dip define-constant ;
|
||||
|
||||
SYNTAX: GAME:
|
||||
CREATE
|
||||
scan-new-word
|
||||
game-attributes parse-main-window-attributes
|
||||
2dup define-attributes-word
|
||||
parse-definition
|
||||
|
|
|
@ -507,7 +507,7 @@ DEFER: [bind-uniform-tuple]
|
|||
] 3bi ;
|
||||
|
||||
: parse-uniform-tuple-definition ( -- class superclass uniforms )
|
||||
CREATE-CLASS scan {
|
||||
scan-new-class scan-token {
|
||||
{ ";" [ uniform-tuple f ] }
|
||||
{ "<" [ scan-word parse-definition [ first3 uniform boa ] map ] }
|
||||
{ "{" [
|
||||
|
|
|
@ -356,7 +356,7 @@ PRIVATE>
|
|||
[ "vertex-format-attributes" set-word-prop ] 2bi ;
|
||||
|
||||
SYNTAX: VERTEX-FORMAT:
|
||||
CREATE-CLASS parse-definition
|
||||
scan-new-class parse-definition
|
||||
[ first4 vertex-attribute boa ] map
|
||||
define-vertex-format ;
|
||||
|
||||
|
@ -365,7 +365,7 @@ SYNTAX: VERTEX-FORMAT:
|
|||
define-struct-class ;
|
||||
|
||||
SYNTAX: VERTEX-STRUCT:
|
||||
CREATE-CLASS scan-word define-vertex-struct ;
|
||||
scan-new-class scan-word define-vertex-struct ;
|
||||
|
||||
TUPLE: vertex-array-object < gpu-object
|
||||
{ program-instance program-instance read-only }
|
||||
|
@ -589,7 +589,7 @@ TYPED: <program-instance> ( program: program -- instance: program-instance )
|
|||
PRIVATE>
|
||||
|
||||
SYNTAX: GLSL-SHADER:
|
||||
CREATE dup
|
||||
scan-new dup
|
||||
dup old-instances [
|
||||
scan-word
|
||||
f
|
||||
|
@ -601,7 +601,7 @@ SYNTAX: GLSL-SHADER:
|
|||
define-constant ;
|
||||
|
||||
SYNTAX: GLSL-SHADER-FILE:
|
||||
CREATE dup
|
||||
scan-new dup
|
||||
dup old-instances [
|
||||
scan-word execute( -- kind )
|
||||
scan-object in-word's-path
|
||||
|
@ -613,7 +613,7 @@ SYNTAX: GLSL-SHADER-FILE:
|
|||
define-constant ;
|
||||
|
||||
SYNTAX: GLSL-PROGRAM:
|
||||
CREATE dup
|
||||
scan-new dup
|
||||
dup old-instances [
|
||||
f
|
||||
lexer get line>>
|
||||
|
|
|
@ -110,7 +110,7 @@ PRIVATE>
|
|||
#! IRC: type "COMMAND" slot1 ...;
|
||||
#! IRC: type "COMMAND" slot1 ... : trailing-slot;
|
||||
SYNTAX: IRC: ( name string parameters -- )
|
||||
CREATE-CLASS
|
||||
scan-new-class
|
||||
[ scan-object register-irc-message-type ] keep
|
||||
";" parse-tokens
|
||||
[ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;
|
||||
|
|
|
@ -30,4 +30,4 @@ ERROR: not-an-integer x ;
|
|||
] keep length
|
||||
10^ / + swap [ neg ] when ;
|
||||
|
||||
SYNTAX: DECIMAL: scan parse-decimal suffix! ;
|
||||
SYNTAX: DECIMAL: scan-token parse-decimal suffix! ;
|
||||
|
|
|
@ -224,7 +224,7 @@ M: no-method error.
|
|||
] if ;
|
||||
|
||||
! Syntax
|
||||
SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
|
||||
SYNTAX: GENERIC: scan-new-word complete-effect define-generic ;
|
||||
|
||||
: parse-method ( -- quot classes generic )
|
||||
parse-definition [ 2 tail ] [ second ] [ first ] tri ;
|
||||
|
@ -232,10 +232,10 @@ SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
|
|||
: create-method-in ( specializer generic -- method )
|
||||
create-method dup save-location f set-word ;
|
||||
|
||||
: CREATE-METHOD ( -- method )
|
||||
: scan-new-method ( -- method )
|
||||
scan-word scan-object swap create-method-in ;
|
||||
|
||||
: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
|
||||
: (METHOD:) ( -- method def ) scan-new-method parse-definition ;
|
||||
|
||||
SYNTAX: METHOD: (METHOD:) define ;
|
||||
|
||||
|
|
|
@ -5,4 +5,4 @@ sequences ;
|
|||
IN: opencl.syntax
|
||||
|
||||
SYNTAX: SINGLETONS-UNION:
|
||||
CREATE-CLASS ";" parse-tokens [ create-class-in [ define-singleton-class ] keep ] map define-union-class ;
|
||||
scan-new-class ";" parse-tokens [ create-class-in [ define-singleton-class ] keep ] map define-union-class ;
|
||||
|
|
|
@ -37,7 +37,7 @@ ERROR: no-pair-method a b generic ;
|
|||
[ drop make-pair-generic ] 2tri ;
|
||||
|
||||
: (PAIR-GENERIC:) ( -- )
|
||||
CREATE-GENERIC complete-effect define-pair-generic ;
|
||||
scan-new-generic complete-effect define-pair-generic ;
|
||||
|
||||
SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ PREDICATE: role < mixin-class
|
|||
"role-slots" word-prop >boolean ;
|
||||
|
||||
: parse-role-definition ( -- class superroles slots )
|
||||
CREATE-CLASS scan {
|
||||
scan-new-class scan-token {
|
||||
{ ";" [ { } { } ] }
|
||||
{ "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
|
||||
{ "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
|
||||
|
|
|
@ -25,4 +25,4 @@ SYMBOLS: unary binary keyword ;
|
|||
[ selector>effect ]
|
||||
bi define-simple-generic ;
|
||||
|
||||
SYNTAX: SELECTOR: scan selector>generic drop ;
|
||||
SYNTAX: SELECTOR: scan-token selector>generic drop ;
|
||||
|
|
|
@ -55,4 +55,4 @@ ERROR: bad-storage-string string reason ;
|
|||
: n>money ( n -- string )
|
||||
3 10 { "" "K" "M" "B" "T" } reduce-magnitude ;
|
||||
|
||||
SYNTAX: STORAGE: scan storage>n suffix! ;
|
||||
SYNTAX: STORAGE: scan-token storage>n suffix! ;
|
||||
|
|
|
@ -35,7 +35,7 @@ SYNTAX: set:
|
|||
dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ;
|
||||
|
||||
SYNTAX: VAR:
|
||||
CREATE-WORD define-variable ;
|
||||
scan-new-word define-variable ;
|
||||
|
||||
M: variable definer drop \ VAR: f ;
|
||||
M: variable definition drop f ;
|
||||
|
@ -59,7 +59,7 @@ PREDICATE: typed-variable < variable
|
|||
} 2cleave (define-variable) ;
|
||||
|
||||
SYNTAX: TYPED-VAR:
|
||||
CREATE-WORD scan-object define-typed-variable ;
|
||||
scan-new-word scan-object define-typed-variable ;
|
||||
|
||||
M: typed-variable definer drop \ TYPED-VAR: f ;
|
||||
M: typed-variable definition "variable-type" word-prop 1quotation ;
|
||||
|
@ -78,7 +78,7 @@ PREDICATE: global-variable < variable
|
|||
global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;
|
||||
|
||||
SYNTAX: GLOBAL:
|
||||
CREATE-WORD define-global ;
|
||||
scan-new-word define-global ;
|
||||
|
||||
M: global-variable definer drop \ GLOBAL: f ;
|
||||
|
||||
|
@ -92,7 +92,7 @@ INTERSECTION: typed-global-variable
|
|||
[ [ [global-setter] ] dip [typed-setter] ] 2bi (define-variable) ;
|
||||
|
||||
SYNTAX: TYPED-GLOBAL:
|
||||
CREATE-WORD scan-object define-typed-global ;
|
||||
scan-new-word scan-object define-typed-global ;
|
||||
|
||||
M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;
|
||||
|
||||
|
|
|
@ -38,17 +38,17 @@ M: variant-class initial-value*
|
|||
":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
|
||||
|
||||
: parse-variant-members ( -- members )
|
||||
[ scan dup ";" = not ]
|
||||
[ scan-token dup ";" = not ]
|
||||
[ parse-variant-member ] produce nip ;
|
||||
|
||||
SYNTAX: VARIANT:
|
||||
CREATE-CLASS
|
||||
scan-new-class
|
||||
parse-variant-members
|
||||
define-variant-class-members ;
|
||||
|
||||
SYNTAX: VARIANT-MEMBER:
|
||||
scan-word
|
||||
scan parse-variant-member
|
||||
scan-token parse-variant-member
|
||||
define-variant-class-member ;
|
||||
|
||||
MACRO: unboa ( class -- )
|
||||
|
|
|
@ -25,4 +25,4 @@ ERROR: git-revision-not-found path ;
|
|||
[ [ input-stream get swap parse-stream call( -- ) ] with-git-object-stream ]
|
||||
[ git-revision-not-found ] if* ;
|
||||
|
||||
SYNTAX: USE-REV: scan scan use-vocab-rev ;
|
||||
SYNTAX: USE-REV: scan-token scan-token use-vocab-rev ;
|
||||
|
|
|
@ -52,7 +52,7 @@ M: lex-hash at*
|
|||
define-syntax word make-inline ;
|
||||
|
||||
SYNTAX: ON-BNF:
|
||||
CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
|
||||
scan-new-word reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
|
||||
main swap at create-bnf ;
|
||||
|
||||
! Tokenizer like standard factor lexer
|
||||
|
|
|
@ -54,7 +54,7 @@ M: model -> dup , ;
|
|||
: <book*> ( quot -- book ) f make-layout f make-book ; inline
|
||||
|
||||
ERROR: not-in-template word ;
|
||||
SYNTAX: $ CREATE-WORD dup
|
||||
SYNTAX: $ scan-new-word dup
|
||||
[ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry (( -- )) define-declared "$" expect ]
|
||||
[ [ <placeholder> [ swap templates get set-at ] keep , ] curry ] bi append! ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue