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 io.streams.string 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     "inspector"
 164     "io"
 165     "io.files"
 166     "kernel"
 167     "listener"
 168     "math"
 169     "math.order"
 170     "memory"
 171     "namespaces"
 172     "prettyprint"
 173     "sequences"
 174     "slicing"
 175     "sorting"
 176     "stack-checker"
 177     "strings"
 178     "syntax"
 179     "tools.annotations"
 180     "tools.apropos"
 181     "tools.crossref"
 182     "tools.disassembler"
 183     "tools.memory"
 184     "tools.profiler"
 185     "tools.test"
 186     "tools.threads"
 187     "tools.time"
 188     "tools.vocabs"
 189     "vocabs"
 190     "vocabs.loader"
 191     "words"
 192     "scratchpad"
 193 } interactive-vocabs set-global
 194
 195 : with-interactive-vocabs ( quot -- )
 196     [
 197         "scratchpad" in set
 198         interactive-vocabs get set-use
 199         call
 200     ] with-scope ; inline
 201
 202 SYMBOL: print-use-hook
 203
 204 print-use-hook global [ [ ] or ] change-at
 205 !
 206 : parse-fresh ( lines -- quot )
 207     [
 208         V{ } clone amended-use set
 209         parse-lines
 210         amended-use get empty? [ print-use-hook get call ] unless
 211     ] with-file-vocabs ;
 212
 213 : parsing-file ( file -- )
 214     "quiet" get [ drop ] [ "Loading " write print flush ] if ;
 215
 216 : filter-moved ( assoc1 assoc2 -- seq )
 217     swap assoc-diff [
 218         drop where dup [ first ] when
 219         file get path>> =
 220     ] assoc-filter keys ;
 221
 222 : removed-definitions ( -- assoc1 assoc2 )
 223     new-definitions old-definitions
 224     [ get first2 assoc-union ] bi@ ;
 225
 226 : removed-classes ( -- assoc1 assoc2 )
 227     new-definitions old-definitions
 228     [ get second ] bi@ ;
 229
 230 : forget-removed-definitions ( -- )
 231     removed-definitions filter-moved forget-all ;
 232
 233 : reset-removed-classes ( -- )
 234     removed-classes
 235     filter-moved [ class? ] filter [ forget-class ] each ;
 236
 237 : fix-class-words ( -- )
 238     #! If a class word had a compound definition which was
 239     #! removed, it must go back to being a symbol.
 240     new-definitions get first2
 241     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 242
 243 : forget-smudged ( -- )
 244     forget-removed-definitions
 245     reset-removed-classes
 246     fix-class-words ;
 247
 248 : finish-parsing ( lines quot -- )
 249     file get
 250     [ record-form ]
 251     [ record-definitions ]
 252     [ record-checksum ]
 253     tri ;
 254
 255 : parse-stream ( stream name -- quot )
 256     [
 257         [
 258             lines dup parse-fresh
 259             tuck finish-parsing
 260             forget-smudged
 261         ] with-source-file
 262     ] with-compilation-unit ;
 263
 264 : parse-file-restarts ( file -- restarts )
 265     "Load " " again" surround t 2array 1array ;
 266
 267 : parse-file ( file -- quot )
 268     [
 269         [
 270             [ parsing-file ] keep
 271             [ utf8 <file-reader> ] keep
 272             parse-stream
 273         ] with-compiler-errors
 274     ] [
 275         over parse-file-restarts rethrow-restarts
 276         drop parse-file
 277     ] recover ;
 278
 279 : run-file ( file -- )
 280     [ parse-file call ] curry assert-depth ;
 281
 282 : ?run-file ( path -- )
 283     dup exists? [ run-file ] [ drop ] if ;