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