core/parser/parser.factor

   1 ! Copyright (C) 2005, 2008 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 quotations io
   5 combinators sorting splitting math.parser effects continuations
   6 io.files io.streams.string vocabs io.encodings.utf8 source-files
   7 classes hashtables compiler.errors compiler.units accessors sets
   8 lexer ;
   9 IN: parser
  10
  11 : location ( -- loc )
  12     file get lexer get line>> 2dup and
  13     [ >r path>> r> 2array ] [ 2drop f ] if ;
  14
  15 : save-location ( definition -- )
  16     location remember-definition ;
  17
  18 SYMBOL: parser-notes
  19
  20 t parser-notes set-global
  21
  22 : parser-notes? ( -- ? )
  23     parser-notes get "quiet" get not and ;
  24
  25 : note. ( str -- )
  26     parser-notes? [
  27         file get [ path>> write ":" write ] when*
  28         lexer get line>> number>string write ": " write
  29         "Note: " write dup print
  30     ] when drop ;
  31
  32 SYMBOL: use
  33 SYMBOL: in
  34
  35 : (use+) ( vocab -- )
  36     vocab-words use get push ;
  37
  38 : use+ ( vocab -- )
  39     load-vocab (use+) ;
  40
  41 : add-use ( seq -- ) [ use+ ] each ;
  42
  43 : set-use ( seq -- )
  44     [ vocab-words ] V{ } map-as sift use set ;
  45
  46 : check-vocab-string ( name -- name )
  47     dup string?
  48     [ "Vocabulary name must be a string" throw ] unless ;
  49
  50 : set-in ( name -- )
  51     check-vocab-string dup in set create-vocab (use+) ;
  52
  53 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
  54
  55 ERROR: no-current-vocab ;
  56
  57 : current-vocab ( -- str )
  58     in get [ no-current-vocab ] unless* ;
  59
  60 : create-in ( str -- word )
  61     current-vocab create dup set-word dup save-location ;
  62
  63 : CREATE ( -- word ) scan create-in ;
  64
  65 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
  66
  67 : word-restarts ( possibilities -- restarts )
  68     natural-sort [
  69         [
  70             "Use the " swap vocabulary>> " vocabulary" 3append
  71         ] keep
  72     ] { } map>assoc ;
  73
  74 TUPLE: no-word-error name ;
  75
  76 : no-word ( name -- newword )
  77     dup no-word-error boa
  78     swap words-named [ forward-reference? not ] filter
  79     word-restarts throw-restarts
  80     dup vocabulary>> (use+) ;
  81
  82 : check-forward ( str word -- word/f )
  83     dup forward-reference? [
  84         drop
  85         use get
  86         [ at ] with map sift
  87         [ forward-reference? not ] find nip
  88     ] [
  89         nip
  90     ] if ;
  91
  92 : search ( str -- word/f )
  93     dup use get assoc-stack check-forward ;
  94
  95 : scan-word ( -- word/number/f )
  96     scan dup [
  97         dup search [ ] [
  98             dup string>number [ ] [ no-word ] ?if
  99         ] ?if
 100     ] when ;
 101
 102 ERROR: staging-violation word ;
 103
 104 : execute-parsing ( word -- )
 105     dup changed-definitions get key? [ staging-violation ] when
 106     execute ;
 107
 108 : scan-object ( -- object )
 109     scan-word dup parsing-word?
 110     [ V{ } clone swap execute-parsing first ] when ;
 111
 112 : parse-step ( accum end -- accum ? )
 113     scan-word {
 114         { [ 2dup eq? ] [ 2drop f ] }
 115         { [ dup not ] [ drop unexpected-eof t ] }
 116         { [ dup delimiter? ] [ unexpected t ] }
 117         { [ dup parsing-word? ] [ nip execute-parsing t ] }
 118         [ pick push drop t ]
 119     } cond ;
 120
 121 : (parse-until) ( accum end -- accum )
 122     dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
 123
 124 : parse-until ( end -- vec )
 125     100 <vector> swap (parse-until) ;
 126
 127 : parsed ( accum obj -- accum ) over push ;
 128
 129 : (parse-lines) ( lexer -- quot )
 130     [ f parse-until >quotation ] with-lexer ;
 131
 132 : parse-lines ( lines -- quot )
 133     lexer-factory get call (parse-lines) ;
 134
 135 : parse-literal ( accum end quot -- accum )
 136     >r parse-until r> call parsed ; inline
 137
 138 : parse-definition ( -- quot )
 139     \ ; parse-until >quotation ;
 140
 141 : (:) ( -- word def ) CREATE-WORD parse-definition ;
 142
 143 ERROR: bad-number ;
 144
 145 : parse-base ( parsed base -- parsed )
 146     scan swap base> [ bad-number ] unless* parsed ;
 147
 148 SYMBOL: bootstrap-syntax
 149
 150 : with-file-vocabs ( quot -- )
 151     [
 152         f in set { "syntax" } set-use
 153         bootstrap-syntax get [ use get push ] when*
 154         call
 155     ] with-scope ; inline
 156
 157 SYMBOL: interactive-vocabs
 158
 159 {
 160     "accessors"
 161     "arrays"
 162     "assocs"
 163     "combinators"
 164     "compiler"
 165     "compiler.errors"
 166     "compiler.units"
 167     "continuations"
 168     "debugger"
 169     "definitions"
 170     "editors"
 171     "help"
 172     "inspector"
 173     "io"
 174     "io.files"
 175     "kernel"
 176     "listener"
 177     "math"
 178     "math.order"
 179     "memory"
 180     "namespaces"
 181     "prettyprint"
 182     "sequences"
 183     "slicing"
 184     "sorting"
 185     "stack-checker"
 186     "strings"
 187     "syntax"
 188     "tools.annotations"
 189     "tools.crossref"
 190     "tools.memory"
 191     "tools.profiler"
 192     "tools.test"
 193     "tools.threads"
 194     "tools.time"
 195     "tools.vocabs"
 196     "vocabs"
 197     "vocabs.loader"
 198     "words"
 199     "scratchpad"
 200 } interactive-vocabs set-global
 201
 202 : with-interactive-vocabs ( quot -- )
 203     [
 204         "scratchpad" in set
 205         interactive-vocabs get set-use
 206         call
 207     ] with-scope ; inline
 208
 209 : parse-fresh ( lines -- quot )
 210     [ parse-lines ] with-file-vocabs ;
 211
 212 : parsing-file ( file -- )
 213     "quiet" get [
 214         drop
 215     ] [
 216         "Loading " write print flush
 217     ] if ;
 218
 219 : filter-moved ( assoc1 assoc2 -- seq )
 220     swap assoc-diff [
 221         drop where dup [ first ] when
 222         file get path>> =
 223     ] assoc-filter keys ;
 224
 225 : removed-definitions ( -- assoc1 assoc2 )
 226     new-definitions old-definitions
 227     [ get first2 assoc-union ] bi@ ;
 228
 229 : removed-classes ( -- assoc1 assoc2 )
 230     new-definitions old-definitions
 231     [ get second ] bi@ ;
 232
 233 : forget-removed-definitions ( -- )
 234     removed-definitions filter-moved forget-all ;
 235
 236 : reset-removed-classes ( -- )
 237     removed-classes
 238     filter-moved [ class? ] filter [ forget-class ] each ;
 239
 240 : fix-class-words ( -- )
 241     #! If a class word had a compound definition which was
 242     #! removed, it must go back to being a symbol.
 243     new-definitions get first2
 244     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 245
 246 : forget-smudged ( -- )
 247     forget-removed-definitions
 248     reset-removed-classes
 249     fix-class-words ;
 250
 251 : finish-parsing ( lines quot -- )
 252     file get
 253     [ record-form ]
 254     [ record-definitions ]
 255     [ record-checksum ]
 256     tri ;
 257
 258 : parse-stream ( stream name -- quot )
 259     [
 260         [
 261             lines dup parse-fresh
 262             tuck finish-parsing
 263             forget-smudged
 264         ] with-source-file
 265     ] with-compilation-unit ;
 266
 267 : parse-file-restarts ( file -- restarts )
 268     "Load " swap " again" 3append t 2array 1array ;
 269
 270 : parse-file ( file -- quot )
 271     [
 272         [
 273             [ parsing-file ] keep
 274             [ utf8 <file-reader> ] keep
 275             parse-stream
 276         ] with-compiler-errors
 277     ] [
 278         over parse-file-restarts rethrow-restarts
 279         drop parse-file
 280     ] recover ;
 281
 282 : run-file ( file -- )
 283     [ dup parse-file call ] assert-depth drop ;
 284
 285 : ?run-file ( path -- )
 286     dup exists? [ run-file ] [ drop ] if ;