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     [ [ path>> ] dip 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 ] when*
  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 TUPLE: no-current-vocab ;
  56
  57 : no-current-vocab ( -- vocab )
  58     \ no-current-vocab boa
  59     { { "Define words in scratchpad vocabulary" "scratchpad" } }
  60     throw-restarts dup set-in ;
  61
  62 : current-vocab ( -- str )
  63     in get [ no-current-vocab ] unless* ;
  64
  65 : create-in ( str -- word )
  66     current-vocab create dup set-word dup save-location ;
  67
  68 : CREATE ( -- word ) scan create-in ;
  69
  70 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
  71
  72 : word-restarts ( name possibilities -- restarts )
  73     natural-sort
  74     [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
  75     swap "Defer word in current vocabulary" swap 2array
  76     suffix ;
  77
  78 ERROR: no-word-error name ;
  79
  80 : <no-word-error> ( name possibilities -- error restarts )
  81     [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
  82
  83 SYMBOL: amended-use?
  84
  85 SYMBOL: auto-use?
  86
  87 : no-word-restarted ( restart-value -- word )
  88     dup word? [
  89         amended-use? on
  90         dup vocabulary>>
  91         [ (use+) ] [
  92             "Added ``" swap "'' vocabulary to search path" 3append note.
  93         ] bi
  94     ] [ create-in ] if ;
  95
  96 : no-word ( name -- newword )
  97     dup words-named [ forward-reference? not ] filter
  98     dup length 1 = auto-use? get and
  99     [ nip first no-word-restarted ]
 100     [ <no-word-error> throw-restarts no-word-restarted ]
 101     if ;
 102
 103 : check-forward ( str word -- word/f )
 104     dup forward-reference? [
 105         drop
 106         use get
 107         [ at ] with map sift
 108         [ forward-reference? not ] find nip
 109     ] [
 110         nip
 111     ] if ;
 112
 113 : search ( str -- word/f )
 114     dup use get assoc-stack check-forward ;
 115
 116 : scan-word ( -- word/number/f )
 117     scan dup [
 118         dup search [ ] [
 119             dup string>number [ ] [ no-word ] ?if
 120         ] ?if
 121     ] when ;
 122
 123 ERROR: staging-violation word ;
 124
 125 : execute-parsing ( word -- )
 126     dup changed-definitions get key? [ staging-violation ] when
 127     execute ;
 128
 129 : scan-object ( -- object )
 130     scan-word dup parsing-word?
 131     [ V{ } clone swap execute-parsing first ] when ;
 132
 133 : parse-step ( accum end -- accum ? )
 134     scan-word {
 135         { [ 2dup eq? ] [ 2drop f ] }
 136         { [ dup not ] [ drop unexpected-eof t ] }
 137         { [ dup delimiter? ] [ unexpected t ] }
 138         { [ dup parsing-word? ] [ nip execute-parsing t ] }
 139         [ pick push drop t ]
 140     } cond ;
 141
 142 : (parse-until) ( accum end -- accum )
 143     [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
 144
 145 : parse-until ( end -- vec )
 146     100 <vector> swap (parse-until) ;
 147
 148 : parsed ( accum obj -- accum ) over push ;
 149
 150 : (parse-lines) ( lexer -- quot )
 151     [
 152         f parse-until >quotation
 153     ] with-lexer ;
 154
 155 : parse-lines ( lines -- quot )
 156     lexer-factory get call (parse-lines) ;
 157
 158 : parse-literal ( accum end quot -- accum )
 159     [ parse-until ] dip call parsed ; inline
 160
 161 : parse-definition ( -- quot )
 162     \ ; parse-until >quotation ;
 163
 164 : (:) ( -- word def ) CREATE-WORD parse-definition ;
 165
 166 ERROR: bad-number ;
 167
 168 : parse-base ( parsed base -- parsed )
 169     scan swap base> [ bad-number ] unless* parsed ;
 170
 171 SYMBOL: bootstrap-syntax
 172
 173 : with-file-vocabs ( quot -- )
 174     [
 175         f in set { "syntax" } set-use
 176         bootstrap-syntax get [ use get push ] when*
 177         call
 178     ] with-scope ; inline
 179
 180 SYMBOL: interactive-vocabs
 181
 182 {
 183     "accessors"
 184     "arrays"
 185     "assocs"
 186     "combinators"
 187     "compiler"
 188     "compiler.errors"
 189     "compiler.units"
 190     "continuations"
 191     "debugger"
 192     "definitions"
 193     "editors"
 194     "help"
 195     "inspector"
 196     "io"
 197     "io.files"
 198     "kernel"
 199     "listener"
 200     "math"
 201     "math.order"
 202     "memory"
 203     "namespaces"
 204     "prettyprint"
 205     "sequences"
 206     "slicing"
 207     "sorting"
 208     "stack-checker"
 209     "strings"
 210     "syntax"
 211     "tools.annotations"
 212     "tools.crossref"
 213     "tools.memory"
 214     "tools.profiler"
 215     "tools.test"
 216     "tools.threads"
 217     "tools.time"
 218     "tools.vocabs"
 219     "vocabs"
 220     "vocabs.loader"
 221     "words"
 222     "scratchpad"
 223 } interactive-vocabs set-global
 224
 225 : with-interactive-vocabs ( quot -- )
 226     [
 227         "scratchpad" in set
 228         interactive-vocabs get set-use
 229         call
 230     ] with-scope ; inline
 231
 232 SYMBOL: print-use-hook
 233
 234 print-use-hook global [ [ ] or ] change-at
 235
 236 : parse-fresh ( lines -- quot )
 237     [
 238         amended-use? off
 239         parse-lines
 240         amended-use? get [
 241             print-use-hook get call
 242         ] when
 243     ] with-file-vocabs ;
 244
 245 : parsing-file ( file -- )
 246     "quiet" get [
 247         drop
 248     ] [
 249         "Loading " write print flush
 250     ] if ;
 251
 252 : filter-moved ( assoc1 assoc2 -- seq )
 253     swap assoc-diff [
 254         drop where dup [ first ] when
 255         file get path>> =
 256     ] assoc-filter keys ;
 257
 258 : removed-definitions ( -- assoc1 assoc2 )
 259     new-definitions old-definitions
 260     [ get first2 assoc-union ] bi@ ;
 261
 262 : removed-classes ( -- assoc1 assoc2 )
 263     new-definitions old-definitions
 264     [ get second ] bi@ ;
 265
 266 : forget-removed-definitions ( -- )
 267     removed-definitions filter-moved forget-all ;
 268
 269 : reset-removed-classes ( -- )
 270     removed-classes
 271     filter-moved [ class? ] filter [ forget-class ] each ;
 272
 273 : fix-class-words ( -- )
 274     #! If a class word had a compound definition which was
 275     #! removed, it must go back to being a symbol.
 276     new-definitions get first2
 277     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 278
 279 : forget-smudged ( -- )
 280     forget-removed-definitions
 281     reset-removed-classes
 282     fix-class-words ;
 283
 284 : finish-parsing ( lines quot -- )
 285     file get
 286     [ record-form ]
 287     [ record-definitions ]
 288     [ record-checksum ]
 289     tri ;
 290
 291 : parse-stream ( stream name -- quot )
 292     [
 293         [
 294             lines dup parse-fresh
 295             tuck finish-parsing
 296             forget-smudged
 297         ] with-source-file
 298     ] with-compilation-unit ;
 299
 300 : parse-file-restarts ( file -- restarts )
 301     "Load " swap " again" 3append t 2array 1array ;
 302
 303 : parse-file ( file -- quot )
 304     [
 305         [
 306             [ parsing-file ] keep
 307             [ utf8 <file-reader> ] keep
 308             parse-stream
 309         ] with-compiler-errors
 310     ] [
 311         over parse-file-restarts rethrow-restarts
 312         drop parse-file
 313     ] recover ;
 314
 315 : run-file ( file -- )
 316     [ dup parse-file call ] assert-depth drop ;
 317
 318 : ?run-file ( path -- )
 319     dup exists? [ run-file ] [ drop ] if ;