1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien arrays byte-arrays definitions generic
4 hashtables kernel math namespaces parser lexer sequences strings
5 strings.parser sbufs vectors words quotations io assocs
6 splitting classes.tuple generic.standard generic.math
7 generic.parser classes io.files vocabs classes.parser
8 classes.union classes.intersection classes.mixin
9 classes.predicate classes.singleton classes.tuple.parser
10 compiler.units combinators effects.parser slots ;
13 ! These words are defined as a top-level form, instead of with
14 ! defining parsing words, because during stage1 bootstrap, the
15 ! "syntax" vocabulary is copied from the host. When stage1
16 ! bootstrap completes, the host's syntax vocabulary is deleted
17 ! from the target, then this top-level form creates the
18 ! target's "syntax" vocabulary as one of the first things done
21 : define-delimiter ( name -- )
22 "syntax" lookup t "delimiter" set-word-prop ;
24 : define-syntax ( name quot -- )
25 [ "syntax" lookup dup ] dip define make-parsing ;
28 { "]" "}" ";" ">>" } [ define-delimiter ] each
31 "Primitive definition is not supported" throw
35 "Call stack literals are not supported" throw
38 "!" [ lexer get next-line ] define-syntax
40 "#!" [ POSTPONE: ! ] define-syntax
42 "IN:" [ scan set-in ] define-syntax
44 "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
47 POSTPONE: PRIVATE> in get ".private" append set-in
50 "USE:" [ scan use+ ] define-syntax
52 "USING:" [ ";" parse-tokens add-use ] define-syntax
54 "HEX:" [ 16 parse-base ] define-syntax
55 "OCT:" [ 8 parse-base ] define-syntax
56 "BIN:" [ 2 parse-base ] define-syntax
58 "f" [ f parsed ] define-syntax
59 "t" "syntax" lookup define-singleton-class
63 { [ dup length 1 = ] [ first ] }
64 { [ "\\" ?head ] [ next-escape >string "" assert= ] }
65 [ name>char-hook get call ]
69 "\"" [ parse-string parsed ] define-syntax
72 lexer get skip-blank parse-string >sbuf parsed
76 lexer get skip-blank parse-string <pathname> parsed
79 "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
80 "{" [ \ } [ >array ] parse-literal ] define-syntax
81 "V{" [ \ } [ >vector ] parse-literal ] define-syntax
82 "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
83 "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
84 "T{" [ parse-tuple-literal parsed ] define-syntax
85 "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
87 "POSTPONE:" [ scan-word parsed ] define-syntax
88 "\\" [ scan-word literalize parsed ] define-syntax
89 "inline" [ word make-inline ] define-syntax
90 "recursive" [ word make-recursive ] define-syntax
91 "foldable" [ word make-foldable ] define-syntax
92 "flushable" [ word make-flushable ] define-syntax
93 "delimiter" [ word t "delimiter" set-word-prop ] define-syntax
94 "parsing" [ word make-parsing ] define-syntax
97 CREATE-WORD define-symbol
101 scan current-vocab create
102 dup old-definitions get [ delete-at ] with each
111 CREATE-GENERIC define-simple-generic
116 scan-word <standard-combination> define-generic
121 T{ math-combination } define-generic
125 CREATE-GENERIC scan-word
126 <hook-combination> define-generic
134 CREATE-CLASS parse-definition define-union-class
138 CREATE-CLASS parse-definition define-intersection-class
142 CREATE-CLASS define-mixin-class
147 scan-word scan-word 2dup add-mixin-instance
149 ] dip remember-definition
156 parse-definition define-predicate-class
160 CREATE-CLASS define-singleton-class
164 parse-tuple-definition define-tuple-class
168 scan define-protocol-slot
173 scan-word [ boa ] curry define-inline
177 parse-tuple-definition
188 word dup [ set-stack-effect ] [ 2drop ] if
192 "))" parse-effect parsed
195 "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax
199 \ >> parse-until >quotation
200 ] with-nested-compilation-unit call
206 \ (call-next-method) parsed
208 not-in-a-method-error
212 "initial:" "syntax" lookup define-symbol
214 "read-only" "syntax" lookup define-symbol
215 ] with-compilation-unit