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