core/parser/parser.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes combinators
   4 compiler.units continuations definitions effects io
   5 io.encodings.utf8 io.files kernel lexer math.parser namespaces
   6 parser.notes quotations sequences slots source-files vectors
   7 vocabs vocabs.parser words words.symbol ;
   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 M: parsing-word stack-effect drop ( parsed -- parsed ) ;
  18
  19 : create-in ( str -- word )
  20     current-vocab create dup set-word dup save-location ;
  21
  22 SYMBOL: auto-use?
  23
  24 : auto-use ( -- ) auto-use? on ;
  25
  26 : no-word-restarted ( restart-value -- word )
  27     dup word? [
  28         dup vocabulary>>
  29         [ auto-use-vocab ]
  30         [ "Added \"" "\" vocabulary to search path" surround note. ] bi
  31     ] [ create-in ] if ;
  32
  33 : ignore-forwards ( seq -- seq' )
  34     [ forward-reference? not ] filter ;
  35
  36 : private? ( word -- ? ) vocabulary>> ".private" tail? ;
  37
  38 : ignore-privates ( seq -- seq' )
  39     dup [ private? ] all? [ [ private? not ] filter ] unless ;
  40
  41 : no-word ( name -- newword )
  42     dup words-named ignore-forwards
  43     dup ignore-privates dup length 1 = auto-use? get and
  44     [ 2nip first no-word-restarted ]
  45     [ drop <no-word-error> throw-restarts no-word-restarted ]
  46     if ;
  47
  48 : parse-word ( string -- word )
  49     dup search [ ] [ no-word ] ?if ;
  50
  51 ERROR: number-expected ;
  52
  53 : parse-number ( string -- number )
  54     string>number [ number-expected ] unless* ;
  55
  56 : parse-datum ( string -- word/number )
  57     dup search [ ] [
  58         dup string>number [ ] [ no-word ] ?if
  59     ] ?if ;
  60
  61 : (scan-datum) ( -- word/number/f )
  62     (scan-token) dup [ parse-datum ] when ;
  63
  64 : scan-datum ( -- word/number )
  65     (scan-datum) [ \ word unexpected-eof ] unless* ;
  66
  67 : scan-word ( -- word )
  68     (scan-token) parse-word ;
  69
  70 : scan-number ( -- number )
  71     (scan-token) parse-number ;
  72
  73 : scan-word-name ( -- string )
  74     scan-token
  75     dup string>number [
  76         "Word names cannot be numbers" throw
  77     ] when ;
  78
  79 : scan-new ( -- word )
  80     scan-word-name create-in ;
  81
  82 : scan-new-word ( -- word )
  83     scan-new dup reset-generic ;
  84
  85 ERROR: staging-violation word ;
  86
  87 : (execute-parsing) ( accum word -- accum )
  88     dup push-parsing-word
  89     execute( accum -- accum )
  90     pop-parsing-word ; inline
  91
  92 : execute-parsing ( accum word -- accum )
  93     dup changed-definitions get key? [ staging-violation ] when
  94     (execute-parsing) ;
  95
  96 : scan-object ( -- object )
  97     scan-datum
  98     dup parsing-word? [
  99         V{ } clone swap execute-parsing first
 100     ] when ;
 101
 102 : scan-class ( -- class )
 103     scan-object \ f or ;
 104
 105 : parse-until-step ( accum end -- accum ? )
 106     (scan-datum) {
 107         { [ 2dup eq? ] [ 2drop f ] }
 108         { [ dup not ] [ drop unexpected-eof t ] }
 109         { [ dup delimiter? ] [ unexpected t ] }
 110         { [ dup parsing-word? ] [ nip execute-parsing t ] }
 111         [ pick push drop t ]
 112     } cond ;
 113
 114 : (parse-until) ( accum end -- accum )
 115     [ parse-until-step ] keep swap [ (parse-until) ] [ drop ] if ;
 116
 117 : parse-until ( end -- vec )
 118     100 <vector> swap (parse-until) ;
 119
 120 SYMBOL: quotation-parser
 121
 122 HOOK: parse-quotation quotation-parser ( -- quot )
 123
 124 M: f parse-quotation \ ] parse-until >quotation ;
 125
 126 : (parse-lines) ( lexer -- quot )
 127     [ f parse-until >quotation ] with-lexer ;
 128
 129 : parse-lines ( lines -- quot )
 130     >array <lexer> (parse-lines) ;
 131
 132 : parse-literal ( accum end quot -- accum )
 133     [ parse-until ] dip call suffix! ; inline
 134
 135 : parse-definition ( -- quot )
 136     \ ; parse-until >quotation ;
 137
 138 ERROR: bad-number ;
 139
 140 : scan-base ( base -- n )
 141     scan-token swap base> [ bad-number ] unless* ;
 142
 143 SYMBOL: bootstrap-syntax
 144
 145 : with-file-vocabs ( quot -- )
 146     [
 147         "syntax" use-vocab
 148         bootstrap-syntax get [ use-words ] when*
 149         call
 150     ] with-manifest ; inline
 151
 152 SYMBOL: print-use-hook
 153
 154 print-use-hook [ [ ] ] initialize
 155
 156 : parse-fresh ( lines -- quot )
 157     [
 158         parse-lines
 159         auto-used? [ print-use-hook get call( -- ) ] when
 160     ] with-file-vocabs ;
 161
 162 : parsing-file ( file -- )
 163     parser-quiet? get [ drop ] [ "Loading " write print flush ] if ;
 164
 165 : filter-moved ( assoc1 assoc2 -- seq )
 166     swap assoc-diff keys [
 167         {
 168             { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
 169             { [ dup reader-method? ] [ f ] }
 170             { [ dup writer-method? ] [ f ] }
 171             [ t ]
 172         } cond nip
 173     ] filter ;
 174
 175 : removed-definitions ( -- assoc1 assoc2 )
 176     new-definitions old-definitions
 177     [ get first2 assoc-union ] bi@ ;
 178
 179 : removed-classes ( -- assoc1 assoc2 )
 180     new-definitions old-definitions
 181     [ get second ] bi@ ;
 182
 183 : forget-removed-definitions ( -- )
 184     removed-definitions filter-moved forget-all ;
 185
 186 : reset-removed-classes ( -- )
 187     removed-classes
 188     filter-moved [ class? ] filter [ forget-class ] each ;
 189
 190 : fix-class-words ( -- )
 191     #! If a class word had a compound definition which was
 192     #! removed, it must go back to being a symbol.
 193     new-definitions get first2
 194     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 195
 196 : forget-smudged ( -- )
 197     forget-removed-definitions
 198     reset-removed-classes
 199     fix-class-words ;
 200
 201 : finish-parsing ( lines quot -- )
 202     file get
 203     [ record-top-level-form ]
 204     [ record-definitions ]
 205     [ record-checksum ]
 206     tri ;
 207
 208 : parse-stream ( stream name -- quot )
 209     [
 210         [
 211             stream-lines dup parse-fresh
 212             [ nip ] [ finish-parsing ] 2bi
 213             forget-smudged
 214         ] with-source-file
 215     ] with-compilation-unit ;
 216
 217 : parse-file-restarts ( file -- restarts )
 218     "Load " " again" surround t 2array 1array ;
 219
 220 : parse-file ( file -- quot )
 221     [
 222         [ parsing-file ] keep
 223         [ utf8 <file-reader> ] keep
 224         parse-stream
 225     ] [
 226         over parse-file-restarts rethrow-restarts
 227         drop parse-file
 228     ] recover ;
 229
 230 : run-file ( file -- )
 231     parse-file call( -- ) ;
 232
 233 : ?run-file ( path -- )
 234     dup exists? [ run-file ] [ drop ] if ;
 235
 236 ERROR: version-control-merge-conflict ;