core/parser/parser.factor

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