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     [ [ vocabulary>> "Use the " " vocabulary" surround ] 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         dup vocabulary>>
  90         [ (use+) ]
  91         [ amended-use get dup [ push ] [ 2drop ] if ]
  92         [ "Added ``" "'' vocabulary to search path" surround note. ]
  93         tri
  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         V{ } clone amended-use set
 239         parse-lines
 240         amended-use get empty? [ print-use-hook get call ] unless
 241     ] with-file-vocabs ;
 242
 243 : parsing-file ( file -- )
 244     "quiet" get [ drop ] [ "Loading " write print flush ] if ;
 245
 246 : filter-moved ( assoc1 assoc2 -- seq )
 247     swap assoc-diff [
 248         drop where dup [ first ] when
 249         file get path>> =
 250     ] assoc-filter keys ;
 251
 252 : removed-definitions ( -- assoc1 assoc2 )
 253     new-definitions old-definitions
 254     [ get first2 assoc-union ] bi@ ;
 255
 256 : removed-classes ( -- assoc1 assoc2 )
 257     new-definitions old-definitions
 258     [ get second ] bi@ ;
 259
 260 : forget-removed-definitions ( -- )
 261     removed-definitions filter-moved forget-all ;
 262
 263 : reset-removed-classes ( -- )
 264     removed-classes
 265     filter-moved [ class? ] filter [ forget-class ] each ;
 266
 267 : fix-class-words ( -- )
 268     #! If a class word had a compound definition which was
 269     #! removed, it must go back to being a symbol.
 270     new-definitions get first2
 271     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 272
 273 : forget-smudged ( -- )
 274     forget-removed-definitions
 275     reset-removed-classes
 276     fix-class-words ;
 277
 278 : finish-parsing ( lines quot -- )
 279     file get
 280     [ record-form ]
 281     [ record-definitions ]
 282     [ record-checksum ]
 283     tri ;
 284
 285 : parse-stream ( stream name -- quot )
 286     [
 287         [
 288             lines dup parse-fresh
 289             tuck finish-parsing
 290             forget-smudged
 291         ] with-source-file
 292     ] with-compilation-unit ;
 293
 294 : parse-file-restarts ( file -- restarts )
 295     "Load " " again" surround t 2array 1array ;
 296
 297 : parse-file ( file -- quot )
 298     [
 299         [
 300             [ parsing-file ] keep
 301             [ utf8 <file-reader> ] keep
 302             parse-stream
 303         ] with-compiler-errors
 304     ] [
 305         over parse-file-restarts rethrow-restarts
 306         drop parse-file
 307     ] recover ;
 308
 309 : run-file ( file -- )
 310     [ parse-file call ] curry assert-depth ;
 311
 312 : ?run-file ( path -- )
 313     dup exists? [ run-file ] [ drop ] if ;