core/parser/parser.factor

   1 ! Copyright (C) 2005, 2009 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 classes
   7 hashtables compiler.units accessors sets lexer vocabs.parser
   8 effects.parser slots ;
   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:" print 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         [ (add-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 : scan-word ( -- word/number/f )
  72     scan dup [
  73         dup search [ ] [
  74             dup string>number [ ] [ no-word ] ?if
  75         ] ?if
  76     ] when ;
  77
  78 ERROR: staging-violation word ;
  79
  80 : execute-parsing ( accum word -- accum )
  81     dup changed-definitions get key? [ staging-violation ] when
  82     execute( accum -- accum ) ;
  83
  84 : scan-object ( -- object )
  85     scan-word dup parsing-word?
  86     [ V{ } clone swap execute-parsing first ] when ;
  87
  88 : parse-step ( accum end -- accum ? )
  89     scan-word {
  90         { [ 2dup eq? ] [ 2drop f ] }
  91         { [ dup not ] [ drop unexpected-eof t ] }
  92         { [ dup delimiter? ] [ unexpected t ] }
  93         { [ dup parsing-word? ] [ nip execute-parsing t ] }
  94         [ pick push drop t ]
  95     } cond ;
  96
  97 : (parse-until) ( accum end -- accum )
  98     [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
  99
 100 : parse-until ( end -- vec )
 101     100 <vector> swap (parse-until) ;
 102
 103 SYMBOL: quotation-parser
 104
 105 HOOK: parse-quotation quotation-parser ( -- quot )
 106
 107 M: f parse-quotation \ ] parse-until >quotation ;
 108
 109 : parsed ( accum obj -- accum ) over push ;
 110
 111 : (parse-lines) ( lexer -- quot )
 112     [ f parse-until >quotation ] with-lexer ;
 113
 114 : parse-lines ( lines -- quot )
 115     lexer-factory get call( lines -- lexer ) (parse-lines) ;
 116
 117 : parse-literal ( accum end quot -- accum )
 118     [ parse-until ] dip call parsed ; inline
 119
 120 : parse-definition ( -- quot )
 121     \ ; parse-until >quotation ;
 122
 123 : (:) ( -- word def effect )
 124     CREATE-WORD
 125     complete-effect
 126     parse-definition swap ;
 127
 128 ERROR: bad-number ;
 129
 130 : parse-base ( parsed base -- parsed )
 131     scan swap base> [ bad-number ] unless* parsed ;
 132
 133 SYMBOL: bootstrap-syntax
 134
 135 : with-file-vocabs ( quot -- )
 136     [
 137         f in set { "syntax" } set-use
 138         bootstrap-syntax get [ use get push ] when*
 139         call
 140     ] with-scope ; inline
 141
 142 SYMBOL: interactive-vocabs
 143
 144 {
 145     "accessors"
 146     "arrays"
 147     "assocs"
 148     "combinators"
 149     "compiler"
 150     "compiler.errors"
 151     "compiler.units"
 152     "continuations"
 153     "debugger"
 154     "definitions"
 155     "editors"
 156     "help"
 157     "help.apropos"
 158     "help.lint"
 159     "help.vocabs"
 160     "inspector"
 161     "io"
 162     "io.files"
 163     "io.pathnames"
 164     "kernel"
 165     "listener"
 166     "math"
 167     "math.order"
 168     "memory"
 169     "namespaces"
 170     "parser"
 171     "prettyprint"
 172     "see"
 173     "sequences"
 174     "slicing"
 175     "sorting"
 176     "stack-checker"
 177     "strings"
 178     "syntax"
 179     "tools.annotations"
 180     "tools.crossref"
 181     "tools.disassembler"
 182     "tools.errors"
 183     "tools.memory"
 184     "tools.profiler"
 185     "tools.test"
 186     "tools.threads"
 187     "tools.time"
 188     "vocabs"
 189     "vocabs.loader"
 190     "vocabs.refresh"
 191     "vocabs.hierarchy"
 192     "words"
 193     "scratchpad"
 194 } interactive-vocabs set-global
 195
 196 : with-interactive-vocabs ( quot -- )
 197     [
 198         "scratchpad" in set
 199         interactive-vocabs get set-use
 200         call
 201     ] with-scope ; inline
 202
 203 SYMBOL: print-use-hook
 204
 205 print-use-hook [ [ ] ] initialize
 206
 207 : parse-fresh ( lines -- quot )
 208     [
 209         V{ } clone amended-use set
 210         parse-lines
 211         amended-use get empty? [ print-use-hook get call( -- ) ] unless
 212     ] with-file-vocabs ;
 213
 214 : parsing-file ( file -- )
 215     "quiet" get [ drop ] [ "Loading " write print flush ] if ;
 216
 217 : filter-moved ( assoc1 assoc2 -- seq )
 218     swap assoc-diff keys [
 219         {
 220             { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
 221             { [ dup reader-method? ] [ f ] }
 222             { [ dup writer-method? ] [ f ] }
 223             [ t ]
 224         } cond nip
 225     ] filter ;
 226
 227 : removed-definitions ( -- assoc1 assoc2 )
 228     new-definitions old-definitions
 229     [ get first2 assoc-union ] bi@ ;
 230
 231 : removed-classes ( -- assoc1 assoc2 )
 232     new-definitions old-definitions
 233     [ get second ] bi@ ;
 234
 235 : forget-removed-definitions ( -- )
 236     removed-definitions filter-moved forget-all ;
 237
 238 : reset-removed-classes ( -- )
 239     removed-classes
 240     filter-moved [ class? ] filter [ forget-class ] each ;
 241
 242 : fix-class-words ( -- )
 243     #! If a class word had a compound definition which was
 244     #! removed, it must go back to being a symbol.
 245     new-definitions get first2
 246     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 247
 248 : forget-smudged ( -- )
 249     forget-removed-definitions
 250     reset-removed-classes
 251     fix-class-words ;
 252
 253 : finish-parsing ( lines quot -- )
 254     file get
 255     [ record-top-level-form ]
 256     [ record-definitions ]
 257     [ record-checksum ]
 258     tri ;
 259
 260 : parse-stream ( stream name -- quot )
 261     [
 262         [
 263             stream-lines dup parse-fresh
 264             [ nip ] [ finish-parsing ] 2bi
 265             forget-smudged
 266         ] with-source-file
 267     ] with-compilation-unit ;
 268
 269 : parse-file-restarts ( file -- restarts )
 270     "Load " " again" surround t 2array 1array ;
 271
 272 : parse-file ( file -- quot )
 273     [
 274         [ parsing-file ] keep
 275         [ utf8 <file-reader> ] keep
 276         parse-stream
 277     ] [
 278         over parse-file-restarts rethrow-restarts
 279         drop parse-file
 280     ] recover ;
 281
 282 : run-file ( file -- )
 283     parse-file call( -- ) ;
 284
 285 : ?run-file ( path -- )
 286     dup exists? [ run-file ] [ drop ] if ;