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