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