1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays bit-arrays byte-arrays byte-vectors
4 definitions generic hashtables kernel math namespaces parser
5 lexer sequences strings strings.parser sbufs vectors
6 words quotations io assocs splitting classes.tuple
7 generic.standard generic.math generic.parser classes io.files
8 vocabs float-arrays classes.parser classes.union
9 classes.intersection classes.mixin classes.predicate
10 classes.singleton classes.tuple.parser compiler.units
11 combinators debugger effects.parser slots ;
14 ! These words are defined as a top-level form, instead of with
15 ! defining parsing words, because during stage1 bootstrap, the
16 ! "syntax" vocabulary is copied from the host. When stage1
17 ! bootstrap completes, the host's syntax vocabulary is deleted
18 ! from the target, then this top-level form creates the
19 ! target's "syntax" vocabulary as one of the first things done
22 : define-delimiter ( name -- )
23 "syntax" lookup t "delimiter" set-word-prop ;
25 : define-syntax ( name quot -- )
26 >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
29 { "]" "}" ";" ">>" } [ define-delimiter ] each
32 "Primitive definition is not supported" throw
36 "Call stack literals are not supported" throw
39 "!" [ lexer get next-line ] define-syntax
41 "#!" [ POSTPONE: ! ] define-syntax
43 "IN:" [ scan set-in ] define-syntax
45 "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
48 POSTPONE: PRIVATE> in get ".private" append set-in
51 "USE:" [ scan use+ ] define-syntax
53 "USING:" [ ";" parse-tokens add-use ] define-syntax
55 "HEX:" [ 16 parse-base ] define-syntax
56 "OCT:" [ 8 parse-base ] define-syntax
57 "BIN:" [ 2 parse-base ] define-syntax
59 "f" [ f parsed ] define-syntax
60 "t" "syntax" lookup define-singleton-class
64 { [ dup length 1 = ] [ first ] }
65 { [ "\\" ?head ] [ next-escape drop ] }
66 [ name>char-hook get call ]
70 "\"" [ parse-string parsed ] define-syntax
73 lexer get skip-blank parse-string >sbuf parsed
77 lexer get skip-blank parse-string <pathname> parsed
80 "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
81 "{" [ \ } [ >array ] parse-literal ] define-syntax
82 "V{" [ \ } [ >vector ] parse-literal ] define-syntax
83 "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
84 "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
85 "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
86 "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
87 "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
88 "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
89 "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
91 "POSTPONE:" [ scan-word parsed ] define-syntax
92 "\\" [ scan-word literalize parsed ] define-syntax
93 "inline" [ word make-inline ] define-syntax
94 "foldable" [ word make-foldable ] define-syntax
95 "flushable" [ word make-flushable ] define-syntax
96 "delimiter" [ word t "delimiter" set-word-prop ] define-syntax
97 "parsing" [ word t "parsing" set-word-prop ] define-syntax
100 CREATE-WORD define-symbol
104 scan current-vocab create
105 dup old-definitions get [ delete-at ] with each
114 CREATE-GENERIC define-simple-generic
119 scan-word <standard-combination> define-generic
124 T{ math-combination } define-generic
128 CREATE-GENERIC scan-word
129 <hook-combination> define-generic
137 CREATE-CLASS parse-definition define-union-class
141 CREATE-CLASS parse-definition define-intersection-class
145 CREATE-CLASS define-mixin-class
150 scan-word scan-word 2dup add-mixin-instance
151 <mixin-instance> r> remember-definition
158 parse-definition define-predicate-class
162 CREATE-CLASS define-singleton-class
166 parse-tuple-definition define-tuple-class
170 scan define-protocol-slot
175 scan-word check-tuple-class
176 [ boa ] curry define-inline
180 parse-tuple-definition
191 word dup [ set-stack-effect ] [ 2drop ] if
195 "))" parse-effect parsed
198 "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
202 \ >> parse-until >quotation
203 ] with-nested-compilation-unit call
207 current-class get current-generic get
208 2dup [ word? ] both? [
209 [ literalize parsed ] bi@
210 \ (call-next-method) parsed
212 not-in-a-method-error
216 "initial:" "syntax" lookup define-symbol
218 "read-only:" "syntax" lookup define-symbol
219 ] with-compilation-unit