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