PageRenderTime 47ms CodeModel.GetById 16ms app.highlight 28ms RepoModel.GetById 1ms app.codeStats 0ms

/core/parser/parser.factor

http://github.com/abeaumont/factor
Unknown | 236 lines | 177 code | 59 blank | 0 comment | 0 complexity | fc3a2a6c5be3f5240c9130144092ca60 MD5 | raw file
  1! Copyright (C) 2005, 2010 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors arrays assocs classes combinators
  4compiler.units continuations definitions effects io
  5io.encodings.utf8 io.files kernel lexer math.parser namespaces
  6parser.notes quotations sequences slots source-files vectors
  7vocabs vocabs.parser words words.symbol ;
  8IN: parser
  9
 10: location ( -- loc )
 11    file get lexer get line>> 2dup and
 12    [ [ path>> ] dip 2array ] [ 2drop f ] if ;
 13
 14: save-location ( definition -- )
 15    location remember-definition ;
 16
 17M: parsing-word stack-effect drop ( parsed -- parsed ) ;
 18
 19: create-in ( str -- word )
 20    current-vocab create dup set-word dup save-location ;
 21
 22SYMBOL: auto-use?
 23
 24: auto-use ( -- ) auto-use? on ;
 25
 26: no-word-restarted ( restart-value -- word )
 27    dup word? [
 28        dup vocabulary>>
 29        [ auto-use-vocab ]
 30        [ "Added \"" "\" vocabulary to search path" surround note. ] bi
 31    ] [ create-in ] if ;
 32
 33: ignore-forwards ( seq -- seq' )
 34    [ forward-reference? not ] filter ;
 35
 36: private? ( word -- ? ) vocabulary>> ".private" tail? ;
 37
 38: ignore-privates ( seq -- seq' )
 39    dup [ private? ] all? [ [ private? not ] filter ] unless ;
 40
 41: no-word ( name -- newword )
 42    dup words-named ignore-forwards
 43    dup ignore-privates dup length 1 = auto-use? get and
 44    [ 2nip first no-word-restarted ]
 45    [ drop <no-word-error> throw-restarts no-word-restarted ]
 46    if ;
 47
 48: parse-word ( string -- word )
 49    dup search [ ] [ no-word ] ?if ;
 50
 51ERROR: number-expected ;
 52
 53: parse-number ( string -- number )
 54    string>number [ number-expected ] unless* ;
 55
 56: parse-datum ( string -- word/number )
 57    dup search [ ] [
 58        dup string>number [ ] [ no-word ] ?if
 59    ] ?if ;
 60
 61: (scan-datum) ( -- word/number/f )
 62    (scan-token) dup [ parse-datum ] when ;
 63
 64: scan-datum ( -- word/number )
 65    (scan-datum) [ \ word unexpected-eof ] unless* ;
 66
 67: scan-word ( -- word )
 68    (scan-token) parse-word ;
 69
 70: scan-number ( -- number )
 71    (scan-token) parse-number ;
 72
 73: scan-word-name ( -- string )
 74    scan-token
 75    dup string>number [
 76        "Word names cannot be numbers" throw
 77    ] when ;
 78
 79: scan-new ( -- word )
 80    scan-word-name create-in ;
 81
 82: scan-new-word ( -- word )
 83    scan-new dup reset-generic ;
 84
 85ERROR: staging-violation word ;
 86
 87: (execute-parsing) ( accum word -- accum )
 88    dup push-parsing-word
 89    execute( accum -- accum )
 90    pop-parsing-word ; inline
 91
 92: execute-parsing ( accum word -- accum )
 93    dup changed-definitions get key? [ staging-violation ] when
 94    (execute-parsing) ;
 95
 96: scan-object ( -- object )
 97    scan-datum
 98    dup parsing-word? [
 99        V{ } clone swap execute-parsing first
100    ] when ;
101
102: scan-class ( -- class )
103    scan-object \ f or ;
104
105: parse-until-step ( accum end -- accum ? )
106    (scan-datum) {
107        { [ 2dup eq? ] [ 2drop f ] }
108        { [ dup not ] [ drop unexpected-eof t ] }
109        { [ dup delimiter? ] [ unexpected t ] }
110        { [ dup parsing-word? ] [ nip execute-parsing t ] }
111        [ pick push drop t ]
112    } cond ;
113
114: (parse-until) ( accum end -- accum )
115    [ parse-until-step ] keep swap [ (parse-until) ] [ drop ] if ;
116
117: parse-until ( end -- vec )
118    100 <vector> swap (parse-until) ;
119
120SYMBOL: quotation-parser
121
122HOOK: parse-quotation quotation-parser ( -- quot )
123
124M: f parse-quotation \ ] parse-until >quotation ;
125
126: (parse-lines) ( lexer -- quot )
127    [ f parse-until >quotation ] with-lexer ;
128
129: parse-lines ( lines -- quot )
130    >array <lexer> (parse-lines) ;
131
132: parse-literal ( accum end quot -- accum )
133    [ parse-until ] dip call suffix! ; inline
134
135: parse-definition ( -- quot )
136    \ ; parse-until >quotation ;
137
138ERROR: bad-number ;
139
140: scan-base ( base -- n )
141    scan-token swap base> [ bad-number ] unless* ;
142
143SYMBOL: bootstrap-syntax
144
145: with-file-vocabs ( quot -- )
146    [
147        "syntax" use-vocab
148        bootstrap-syntax get [ use-words ] when*
149        call
150    ] with-manifest ; inline
151
152SYMBOL: print-use-hook
153
154print-use-hook [ [ ] ] initialize
155
156: parse-fresh ( lines -- quot )
157    [
158        parse-lines
159        auto-used? [ print-use-hook get call( -- ) ] when
160    ] with-file-vocabs ;
161
162: parsing-file ( file -- )
163    parser-quiet? get [ drop ] [ "Loading " write print flush ] if ;
164
165: filter-moved ( assoc1 assoc2 -- seq )
166    swap assoc-diff keys [
167        {
168            { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
169            { [ dup reader-method? ] [ f ] }
170            { [ dup writer-method? ] [ f ] }
171            [ t ]
172        } cond nip
173    ] filter ;
174
175: removed-definitions ( -- assoc1 assoc2 )
176    new-definitions old-definitions
177    [ get first2 assoc-union ] bi@ ;
178
179: removed-classes ( -- assoc1 assoc2 )
180    new-definitions old-definitions
181    [ get second ] bi@ ;
182
183: forget-removed-definitions ( -- )
184    removed-definitions filter-moved forget-all ;
185
186: reset-removed-classes ( -- )
187    removed-classes
188    filter-moved [ class? ] filter [ forget-class ] each ;
189
190: fix-class-words ( -- )
191    #! If a class word had a compound definition which was
192    #! removed, it must go back to being a symbol.
193    new-definitions get first2
194    filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
195
196: forget-smudged ( -- )
197    forget-removed-definitions
198    reset-removed-classes
199    fix-class-words ;
200
201: finish-parsing ( lines quot -- )
202    file get
203    [ record-top-level-form ]
204    [ record-definitions ]
205    [ record-checksum ]
206    tri ;
207
208: parse-stream ( stream name -- quot )
209    [
210        [
211            stream-lines dup parse-fresh
212            [ nip ] [ finish-parsing ] 2bi
213            forget-smudged
214        ] with-source-file
215    ] with-compilation-unit ;
216
217: parse-file-restarts ( file -- restarts )
218    "Load " " again" surround t 2array 1array ;
219
220: parse-file ( file -- quot )
221    [
222        [ parsing-file ] keep
223        [ utf8 <file-reader> ] keep
224        parse-stream
225    ] [
226        over parse-file-restarts rethrow-restarts
227        drop parse-file
228    ] recover ;
229
230: run-file ( file -- )
231    parse-file call( -- ) ;
232
233: ?run-file ( path -- )
234    dup exists? [ run-file ] [ drop ] if ;
235
236ERROR: version-control-merge-conflict ;