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 parser.notes ;
   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 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
  19
  20 : create-in ( str -- word )
  21     current-vocab create dup set-word dup save-location ;
  22
  23 : CREATE ( -- word ) scan create-in ;
  24
  25 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
  26
  27 SYMBOL: auto-use?
  28
  29 : no-word-restarted ( restart-value -- word )
  30     dup word? [
  31         dup vocabulary>>
  32         [ auto-use-vocab ]
  33         [ "Added \"" "\" vocabulary to search path" surround note. ] bi
  34     ] [ create-in ] if ;
  35
  36 : no-word ( name -- newword )
  37     dup words-named [ forward-reference? not ] filter
  38     dup length 1 = auto-use? get and
  39     [ nip first no-word-restarted ]
  40     [ <no-word-error> throw-restarts no-word-restarted ]
  41     if ;
  42
  43 : parse-word ( string -- word/number )
  44     dup search [ ] [
  45         dup string>number [ ] [ no-word ] ?if
  46     ] ?if ;
  47
  48 : scan-word ( -- word/number/f )
  49     scan dup [ parse-word ] when ;
  50
  51 ERROR: staging-violation word ;
  52
  53 : execute-parsing ( accum word -- accum )
  54     dup changed-definitions get key? [ staging-violation ] when
  55     execute( accum -- accum ) ;
  56
  57 : scan-object ( -- object )
  58     scan-word {
  59         { [ dup not ] [ unexpected-eof ] }
  60         { [ dup parsing-word? ] [ V{ } clone swap execute-parsing first ] }
  61         [ ]
  62     } cond  ;
  63
  64 : parse-step ( accum end -- accum ? )
  65     scan-word {
  66         { [ 2dup eq? ] [ 2drop f ] }
  67         { [ dup not ] [ drop unexpected-eof t ] }
  68         { [ dup delimiter? ] [ unexpected t ] }
  69         { [ dup parsing-word? ] [ nip execute-parsing t ] }
  70         [ pick push drop t ]
  71     } cond ;
  72
  73 : (parse-until) ( accum end -- accum )
  74     [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
  75
  76 : parse-until ( end -- vec )
  77     100 <vector> swap (parse-until) ;
  78
  79 SYMBOL: quotation-parser
  80
  81 HOOK: parse-quotation quotation-parser ( -- quot )
  82
  83 M: f parse-quotation \ ] parse-until >quotation ;
  84
  85 : (parse-lines) ( lexer -- quot )
  86     [ f parse-until >quotation ] with-lexer ;
  87
  88 : parse-lines ( lines -- quot )
  89     lexer-factory get call( lines -- lexer ) (parse-lines) ;
  90
  91 : parse-literal ( accum end quot -- accum )
  92     [ parse-until ] dip call suffix! ; inline
  93
  94 : parse-definition ( -- quot )
  95     \ ; parse-until >quotation ;
  96
  97 : (:) ( -- word def effect )
  98     CREATE-WORD
  99     complete-effect
 100     parse-definition swap ;
 101
 102 ERROR: bad-number ;
 103
 104 : scan-base ( base -- n )
 105     scan swap base> [ bad-number ] unless* ;
 106
 107 : parse-base ( parsed base -- parsed )
 108     scan-base suffix! ;
 109
 110 SYMBOL: bootstrap-syntax
 111
 112 : with-file-vocabs ( quot -- )
 113     [
 114         <manifest> manifest set
 115         "syntax" use-vocab
 116         bootstrap-syntax get [ use-words ] when*
 117         call
 118     ] with-scope ; inline
 119
 120 SYMBOL: print-use-hook
 121
 122 print-use-hook [ [ ] ] initialize
 123
 124 : parse-fresh ( lines -- quot )
 125     [
 126         parse-lines
 127         auto-used? [ print-use-hook get call( -- ) ] when
 128     ] with-file-vocabs ;
 129
 130 : parsing-file ( file -- )
 131     "quiet" get [ drop ] [ "Loading " write print flush ] if ;
 132
 133 : filter-moved ( assoc1 assoc2 -- seq )
 134     swap assoc-diff keys [
 135         {
 136             { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
 137             { [ dup reader-method? ] [ f ] }
 138             { [ dup writer-method? ] [ f ] }
 139             [ t ]
 140         } cond nip
 141     ] filter ;
 142
 143 : removed-definitions ( -- assoc1 assoc2 )
 144     new-definitions old-definitions
 145     [ get first2 assoc-union ] bi@ ;
 146
 147 : removed-classes ( -- assoc1 assoc2 )
 148     new-definitions old-definitions
 149     [ get second ] bi@ ;
 150
 151 : forget-removed-definitions ( -- )
 152     removed-definitions filter-moved forget-all ;
 153
 154 : reset-removed-classes ( -- )
 155     removed-classes
 156     filter-moved [ class? ] filter [ forget-class ] each ;
 157
 158 : fix-class-words ( -- )
 159     #! If a class word had a compound definition which was
 160     #! removed, it must go back to being a symbol.
 161     new-definitions get first2
 162     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 163
 164 : forget-smudged ( -- )
 165     forget-removed-definitions
 166     reset-removed-classes
 167     fix-class-words ;
 168
 169 : finish-parsing ( lines quot -- )
 170     file get
 171     [ record-top-level-form ]
 172     [ record-definitions ]
 173     [ record-checksum ]
 174     tri ;
 175
 176 : parse-stream ( stream name -- quot )
 177     [
 178         [
 179             stream-lines dup parse-fresh
 180             [ nip ] [ finish-parsing ] 2bi
 181             forget-smudged
 182         ] with-source-file
 183     ] with-compilation-unit ;
 184
 185 : parse-file-restarts ( file -- restarts )
 186     "Load " " again" surround t 2array 1array ;
 187
 188 : parse-file ( file -- quot )
 189     [
 190         [ parsing-file ] keep
 191         [ utf8 <file-reader> ] keep
 192         parse-stream
 193     ] [
 194         over parse-file-restarts rethrow-restarts
 195         drop parse-file
 196     ] recover ;
 197
 198 : run-file ( file -- )
 199     parse-file call( -- ) ;
 200
 201 : ?run-file ( path -- )
 202     dup exists? [ run-file ] [ drop ] if ;