1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays byte-arrays byte-vectors classes
4 classes.algebra.private classes.builtin classes.error
5 classes.intersection classes.maybe classes.mixin classes.parser
6 classes.predicate classes.singleton classes.tuple
7 classes.tuple.parser classes.union combinators compiler.units
8 definitions effects effects.parser fry generic generic.hook
9 generic.math generic.parser generic.standard hash-sets
10 hashtables hashtables.identity init io.pathnames kernel lexer
11 locals.errors locals.parser macros math memoize namespaces
12 parser quotations sbufs sequences slots source-files splitting
13 strings strings.parser strings.parser.private vectors
14 vocabs.loader vocabs.parser words words.alias words.constant
18 ! These words are defined as a top-level form, instead of with
19 ! defining parsing words, because during stage1 bootstrap, the
20 ! "syntax" vocabulary is copied from the host. When stage1
21 ! bootstrap completes, the host's syntax vocabulary is deleted
22 ! from the target, then this top-level form creates the
23 ! target's "syntax" vocabulary as one of the first things done
26 : define-delimiter ( name -- )
27 "syntax" lookup-word t "delimiter" set-word-prop ;
29 : define-core-syntax ( name quot -- )
30 [ dup "syntax" lookup-word [ ] [ no-word-error ] ?if ] dip
34 { "]" "}" ";" ">>" } [ define-delimiter ] each
38 scan-word scan-effect ensure-primitive
42 "Call stack literals are not supported" throw
45 "IN:" [ scan-token set-current-vocab ] define-core-syntax
47 "<PRIVATE" [ begin-private ] define-core-syntax
49 "PRIVATE>" [ end-private ] define-core-syntax
51 "REUSE:" [ scan-token reload ] define-core-syntax
53 "USE:" [ scan-token use-vocab ] define-core-syntax
55 "UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
57 "USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
59 "QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
61 "QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
64 scan-token "=>" expect ";" parse-tokens add-words-from
68 scan-token "=>" expect ";" parse-tokens add-words-excluding
72 scan-token scan-token "=>" expect scan-token add-renamed-word
75 "NAN:" [ 16 scan-base <fp-nan> suffix! ] define-core-syntax
77 "f" [ f suffix! ] define-core-syntax
80 lexer get parse-raw [ "token" throw-unexpected-eof ] unless* {
81 { [ dup length 1 = ] [ first ] }
82 { [ "\\" ?head ] [ next-escape >string "" assert= ] }
83 [ name>char-hook get call( name -- char ) ]
87 "\"" [ parse-string suffix! ] define-core-syntax
90 lexer get skip-blank parse-string >sbuf suffix!
94 lexer get skip-blank parse-string <pathname> suffix!
97 "[" [ parse-quotation suffix! ] define-core-syntax
98 "{" [ \ } [ >array ] parse-literal ] define-core-syntax
99 "V{" [ \ } [ >vector ] parse-literal ] define-core-syntax
100 "B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax
101 "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax
102 "H{" [ \ } [ parse-hashtable ] parse-literal ] define-core-syntax
103 "IH{" [ \ } [ >identity-hashtable ] parse-literal ] define-core-syntax
104 "T{" [ parse-tuple-literal suffix! ] define-core-syntax
105 "W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
106 "HS{" [ \ } [ >hash-set ] parse-literal ] define-core-syntax
108 "POSTPONE:" [ scan-word suffix! ] define-core-syntax
109 "\\" [ scan-word <wrapper> suffix! ] define-core-syntax
110 "M\\" [ scan-word scan-word lookup-method <wrapper> suffix! ] define-core-syntax
111 "auto-use" [ t auto-use? set-global ] define-core-syntax
112 "delimiter" [ last-word t "delimiter" set-word-prop ] define-core-syntax
113 "deprecated" [ last-word make-deprecated ] define-core-syntax
114 "flushable" [ last-word make-flushable ] define-core-syntax
115 "foldable" [ last-word make-foldable ] define-core-syntax
116 "inline" [ last-word make-inline ] define-core-syntax
117 "recursive" [ last-word make-recursive ] define-core-syntax
120 scan-new-word parse-definition define-syntax
125 current-vocab lookup-word
126 (parse-tuple-definition)
127 2drop builtin-class check-instance drop
131 scan-new-word define-symbol
135 ";" [ create-word-in [ reset-generic ] [ define-symbol ] bi ] each-token
139 scan-word parse-definition [ initialize ] 2curry append!
143 ";" [ create-class-in define-singleton-class ] each-token
147 scan-token current-vocab create-word
148 [ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
152 scan-new-word scan-word define-alias
156 scan-new-word scan-object define-constant
164 [ simple-combination ] (GENERIC:)
168 [ scan-number <standard-combination> ] (GENERIC:)
172 [ math-combination ] (GENERIC:)
176 [ scan-word <hook-combination> ] (GENERIC:)
184 scan-new-class parse-array-def define-union-class
188 scan-new-class parse-array-def define-intersection-class
192 scan-new-class define-mixin-class
197 scan-word scan-word 2dup add-mixin-instance
199 ] dip remember-definition
206 parse-definition define-predicate-class
210 scan-new-class define-singleton-class
214 parse-tuple-definition define-tuple-class
222 scan-token define-protocol-slot
226 scan-new-word scan-word define-boa-word
230 parse-tuple-definition
240 ")" parse-effect suffix!
244 scan-word dup \ [ = [
245 drop "( main )" <uninterned-word> dup
246 parse-quotation ( -- ) define-declared
247 ] when dup ( -- ) check-stack-effect
248 [ current-vocab main<< ]
249 [ current-source-file get [ main<< ] [ drop ] if* ] bi
254 \ >> parse-until >quotation
255 ] with-nested-compilation-unit call( -- )
261 \ (call-next-method) suffix!
263 not-in-a-method-error
268 \ } [ <anonymous-union> <maybe> ] parse-literal
272 \ } [ <anonymous-union> <anonymous-complement> ] parse-literal
276 \ } [ <anonymous-intersection> ] parse-literal
280 \ } [ <anonymous-union> ] parse-literal
283 "initial:" "syntax" lookup-word define-symbol
285 "read-only" "syntax" lookup-word define-symbol
287 "call(" [ \ call-effect parse-call-paren ] define-core-syntax
289 "execute(" [ \ execute-effect parse-call-paren ] define-core-syntax
291 "<<<<<<<" [ version-control-merge-conflict ] define-core-syntax
292 "=======" [ version-control-merge-conflict ] define-core-syntax
293 ">>>>>>>" [ version-control-merge-conflict ] define-core-syntax
295 "<<<<<<" [ version-control-merge-conflict ] define-core-syntax
296 "======" [ version-control-merge-conflict ] define-core-syntax
297 ">>>>>>" [ version-control-merge-conflict ] define-core-syntax
300 t in-fry? [ parse-quotation ] with-variable fry append!
304 t in-fry? [ \ } parse-until >array ] with-variable fry append!
308 t in-fry? [ \ } parse-until >array ] with-variable fry
309 [ >hash-set ] compose append!
313 t in-fry? [ \ } parse-until >array ] with-variable fry
314 [ parse-hashtable ] compose append!
318 in-fry? get [ \ _ suffix! ] [ not-in-a-fry ] if
322 in-fry? get [ \ @ suffix! ] [ not-in-a-fry ] if
325 "MACRO:" [ (:) define-macro ] define-core-syntax
327 "MEMO:" [ (:) define-memoized ] define-core-syntax
328 "IDENTITY-MEMO:" [ (:) define-identity-memoized ] define-core-syntax
331 in-lambda? get [ :>-outside-lambda-error ] unless
332 scan-token parse-def suffix!
334 "[|" [ parse-lambda append! ] define-core-syntax
335 "[let" [ parse-let append! ] define-core-syntax
337 "::" [ (::) define-declared ] define-core-syntax
338 "M::" [ (M::) define ] define-core-syntax
339 "MACRO::" [ (::) define-macro ] define-core-syntax
340 "MEMO::" [ (::) define-memoized ] define-core-syntax
341 "IDENTITY-MEMO::" [ (::) define-identity-memoized ] define-core-syntax
345 dup \ [ = [ drop parse-quotation ] [ 1quotation ] if
346 current-vocab name>> [ add-startup-hook ] 2curry append!
351 dup \ [ = [ drop parse-quotation ] [ 1quotation ] if
352 current-vocab name>> [ add-shutdown-hook ] 2curry append!
354 ] with-compilation-unit