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