: 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 ;
} cleave ;
: CREATE-C-TYPE ( -- word )
- scan (CREATE-C-TYPE) ;
+ (scan-token) (CREATE-C-TYPE) ;
<PRIVATE
GENERIC: return-type-name ( type -- name )
[ [ 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>
[ 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
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 ;
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! ;
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 ;
\ No newline at end of file
+ 2bi ;
<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 {
} 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>
<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 ]
: 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
[ 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
: named-color ( name -- color )
dup colors at [ ] [ no-such-color ] ?if ;
-SYNTAX: COLOR: scan named-color suffix! ;
+SYNTAX: COLOR: scan-token named-color suffix! ;
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >integer ] tri@ "%02X%02X%02X" sprintf ;
-SYNTAX: HEXCOLOR: scan hex>rgba suffix! ;
+SYNTAX: HEXCOLOR: scan-token hex>rgba suffix! ;
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 ;
} 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 ;
;FUNCTOR
-SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ;
\ No newline at end of file
+SYNTAX: RENAMING: scan-token scan-object scan-object scan-object define-renaming ;
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 ;
define
] 2bi ;
-SYNTAX: ICON: scan-word scan define-icon ;
+SYNTAX: ICON: scan-word scan-token define-icon ;
>>
] 2bi ;
SYNTAX: PROTOCOL:
- CREATE-WORD parse-definition define-protocol ;
+ scan-new-word parse-definition define-protocol ;
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
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 ;
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 ;
FUNCTOR-SYNTAX: TUPLE:
scan-param suffix!
- scan {
+ (scan-token) {
{ ";" [ tuple suffix! f suffix! ] }
{ "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] }
[
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>
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>
PRIVATE>
-SYNTAX: GIR: scan define-gir-vocab ;
+SYNTAX: GIR: scan-token define-gir-vocab ;
SYNTAX: IMPLEMENT-STRUCTS:
";" parse-tokens
: 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"
PRIVATE>
-SYNTAX: 8-BIT: scan scan scan load-encoding ;
+SYNTAX: 8-BIT: scan-token scan-token scan-token load-encoding ;
SYNTAX: EUC:
! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
- CREATE-CLASS scan-object define-euc ;
+ scan-new-class scan-object define-euc ;
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! ;
[ 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
\r
SYNTAX: LOG:\r
#! Syntax: name level\r
- CREATE-WORD dup scan-word\r
+ scan-new-word dup scan-word\r
'[ 1array stack>message _ _ log-message ]\r
(( message -- )) define-declared ;\r
\r
[ 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>
>>
;FUNCTOR
SYNTAX: SIMD-128:
- scan define-simd-128 ;
+ scan-token define-simd-128 ;
PRIVATE>
] "" make but-last ;
SYNTAX: STRING:
- CREATE-WORD
+ scan-new-word
parse-here 1quotation
(( -- string )) define-inline ;
: 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 ]
drop "Tokenizer not found" ;\r
\r
SYNTAX: TOKENIZER: \r
- scan dup search [ nip ] [ no-tokenizer ] if*\r
+ scan-word-name dup search [ nip ] [ no-tokenizer ] if*\r
execute( -- tokenizer ) \ tokenizer set-global ;\r
\r
TUPLE: ebnf-non-terminal symbol ;\r
suffix! \ call suffix! reset-tokenizer ;\r
\r
SYNTAX: EBNF: \r
- reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
+ reset-tokenizer scan-new-word dup ";EBNF" parse-multiline-string \r
ebnf>quot swapd\r
(( input -- ast )) define-declared "ebnf-parser" set-word-prop \r
reset-tokenizer ;\r
ROMAN-OP: /i ( x y -- z )
ROMAN-OP: /mod ( x y -- z w )
-SYNTAX: ROMAN: scan roman> suffix! ;
+SYNTAX: ROMAN: scan-token roman> suffix! ;
<<
SYNTAX: TEST:
- scan
+ scan-token
[ create-in ]
[ "(" ")" surround search '[ _ parse-test ] ] bi
define-syntax ;
PRIVATE>
SYNTAX: TR:
- scan parse-definition
+ scan-token parse-definition
unclip-last [ unclip-last ] dip compute-tr
[ check-tr ]
[ [ create-tr ] dip define-tr ]
;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>
] [ 2drop current-vocab main<< ] 3bi ;
SYNTAX: MAIN-WINDOW:
- CREATE
+ scan-new-word
world-attributes parse-main-window-attributes
parse-definition
define-main-window ;
[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* ;
} 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 ;
<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 ;
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
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
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 ;
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 ;
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:
";" 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 ]
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 ;
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 ] }
[ ")" parse-effect ] dip 2array append! ;
: (:) ( -- word def effect )
- CREATE-WORD
+ scan-new-word
complete-effect
parse-definition swap ;
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 ;
: 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
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 ;
{ $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?
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." } ;
[ (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 ;
"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: }
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: ; }
{ $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." }
{ $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 ;
[ ] [ "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
: 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 )
[ 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 ;
(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 ] }
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! ;
"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:" [
] 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
":" [
] 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:" [
] 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:" [
] define-core-syntax
"C:" [
- CREATE-WORD scan-word define-boa-word
+ scan-new-word scan-word define-boa-word
] define-core-syntax
"ERROR:" [
<<
SYNTAX: HOLIDAY:
- CREATE-WORD
+ scan-new-word
dup "holiday" word-prop [
dup H{ } clone "holiday" set-word-prop
] unless
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 ;
V{ } registers set-global
SYNTAX: REGISTER:
- CREATE-WORD
+ scan-new-word
[ define-symbol ]
[ registers get length "register" set-word-prop ]
[ registers get push ]
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 ;
[ [ 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! ;
[ 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
] 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 ] }
{ "{" [
[ "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 ;
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 }
PRIVATE>
SYNTAX: GLSL-SHADER:
- CREATE dup
+ scan-new dup
dup old-instances [
scan-word
f
define-constant ;
SYNTAX: GLSL-SHADER-FILE:
- CREATE dup
+ scan-new dup
dup old-instances [
scan-word execute( -- kind )
scan-object in-word's-path
define-constant ;
SYNTAX: GLSL-PROGRAM:
- CREATE dup
+ scan-new dup
dup old-instances [
f
lexer get line>>
#! 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 ;
] keep length
10^ / + swap [ neg ] when ;
-SYNTAX: DECIMAL: scan parse-decimal suffix! ;
+SYNTAX: DECIMAL: scan-token parse-decimal suffix! ;
] 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 ;
: 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 ;
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 ;
[ 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:) ;
"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 ] }
[ selector>effect ]
bi define-simple-generic ;
-SYNTAX: SELECTOR: scan selector>generic drop ;
\ No newline at end of file
+SYNTAX: SELECTOR: scan-token selector>generic drop ;
: 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! ;
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 ;
} 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 ;
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 ;
[ [ [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 ;
":" ?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 -- )
[ [ 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 ;
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
: <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! ;
projects / factor.git / commitdiff