core/parser/parser.factor

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