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