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