core/parser/parser.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions generic assocs kernel math namespaces
   4 prettyprint sequences strings vectors words quotations inspector
   5 io.styles io combinators sorting splitting math.parser effects
   6 continuations debugger io.files io.streams.string vocabs
   7 io.encodings.utf8 source-files classes classes.tuple hashtables
   8 compiler.errors compiler.units accessors sets ;
   9 IN: parser
  10
  11 TUPLE: lexer text line line-text line-length column ;
  12
  13 : next-line ( lexer -- )
  14     dup [ line>> ] [ text>> ] bi ?nth >>line-text
  15     dup line-text>> length >>line-length
  16     [ 1+ ] change-line
  17     0 >>column
  18     drop ;
  19
  20 : new-lexer ( text class -- lexer )
  21     new
  22         0 >>line
  23         swap >>text
  24     dup next-line ; inline
  25
  26 : <lexer> ( text -- lexer )
  27     lexer new-lexer ;
  28
  29 : location ( -- loc )
  30     file get lexer get lexer-line 2dup and
  31     [ >r source-file-path r> 2array ] [ 2drop f ] if ;
  32
  33 : save-location ( definition -- )
  34     location remember-definition ;
  35
  36 : save-class-location ( class -- )
  37     location remember-class ;
  38
  39 SYMBOL: parser-notes
  40
  41 t parser-notes set-global
  42
  43 : parser-notes? ( -- ? )
  44     parser-notes get "quiet" get not and ;
  45
  46 : file. ( file -- )
  47     [
  48         source-file-path <pathname> pprint
  49     ] [
  50         "<interactive>" write
  51     ] if* ":" write ;
  52
  53 : note. ( str -- )
  54     parser-notes? [
  55         file get file.
  56         lexer get [
  57             lexer-line number>string print
  58         ] [
  59             nl
  60         ] if*
  61         "Note: " write dup print
  62     ] when drop ;
  63
  64 : skip ( i seq ? -- n )
  65     over >r
  66     [ swap CHAR: \s eq? xor ] curry find-from drop
  67     [ r> drop ] [ r> length ] if* ;
  68
  69 : change-lexer-column ( lexer quot -- )
  70     swap
  71     [ dup lexer-column swap lexer-line-text rot call ] keep
  72     set-lexer-column ; inline
  73
  74 GENERIC: skip-blank ( lexer -- )
  75
  76 M: lexer skip-blank ( lexer -- )
  77     [ t skip ] change-lexer-column ;
  78
  79 GENERIC: skip-word ( lexer -- )
  80
  81 M: lexer skip-word ( lexer -- )
  82     [
  83         2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
  84     ] change-lexer-column ;
  85
  86 : still-parsing? ( lexer -- ? )
  87     dup lexer-line swap lexer-text length <= ;
  88
  89 : still-parsing-line? ( lexer -- ? )
  90     dup lexer-column swap lexer-line-length < ;
  91
  92 : (parse-token) ( lexer -- str )
  93     [ lexer-column ] keep
  94     [ skip-word ] keep
  95     [ lexer-column ] keep
  96     lexer-line-text subseq ;
  97
  98 :  parse-token ( lexer -- str/f )
  99     dup still-parsing? [
 100         dup skip-blank
 101         dup still-parsing-line?
 102         [ (parse-token) ] [ dup next-line parse-token ] if
 103     ] [ drop f ] if ;
 104
 105 : scan ( -- str/f ) lexer get parse-token ;
 106
 107 ERROR: bad-escape ;
 108
 109 M: bad-escape summary drop "Bad escape code" ;
 110
 111 : escape ( escape -- ch )
 112     H{
 113         { CHAR: a  CHAR: \a }
 114         { CHAR: e  CHAR: \e }
 115         { CHAR: n  CHAR: \n }
 116         { CHAR: r  CHAR: \r }
 117         { CHAR: t  CHAR: \t }
 118         { CHAR: s  CHAR: \s }
 119         { CHAR: \s CHAR: \s }
 120         { CHAR: 0  CHAR: \0 }
 121         { CHAR: \\ CHAR: \\ }
 122         { CHAR: \" CHAR: \" }
 123     } at [ bad-escape ] unless* ;
 124
 125 SYMBOL: name>char-hook
 126
 127 name>char-hook global [
 128     [ "Unicode support not available" throw ] or
 129 ] change-at
 130
 131 : unicode-escape ( str -- ch str' )
 132     "{" ?head-slice [
 133         CHAR: } over index cut-slice
 134         >r >string name>char-hook get call r>
 135         rest-slice
 136     ] [
 137         6 cut-slice >r hex> r>
 138     ] if ;
 139
 140 : next-escape ( str -- ch str' )
 141     "u" ?head-slice [
 142         unicode-escape
 143     ] [
 144         unclip-slice escape swap
 145     ] if ;
 146
 147 : (parse-string) ( str -- m )
 148     dup [ "\"\\" member? ] find dup [
 149         >r cut-slice >r % r> rest-slice r>
 150         dup CHAR: " = [
 151             drop slice-from
 152         ] [
 153             drop next-escape >r , r> (parse-string)
 154         ] if
 155     ] [
 156         "Unterminated string" throw
 157     ] if ;
 158
 159 : parse-string ( -- str )
 160     lexer get [
 161         [ swap tail-slice (parse-string) ] "" make swap
 162     ] change-lexer-column ;
 163
 164 TUPLE: parse-error file line column line-text error ;
 165
 166 : <parse-error> ( msg -- error )
 167     \ parse-error new
 168         file get >>file
 169         lexer get line>> >>line
 170         lexer get column>> >>column
 171         lexer get line-text>> >>line-text
 172         swap >>error ;
 173
 174 : parse-dump ( error -- )
 175     {
 176         [ file>> file. ]
 177         [ line>> number>string print ]
 178         [ line-text>> dup string? [ print ] [ drop ] if ]
 179         [ column>> 0 or CHAR: \s <string> write ]
 180     } cleave
 181     "^" print ;
 182
 183 M: parse-error error.
 184     [ parse-dump ] [ error>> error. ] bi ;
 185
 186 M: parse-error summary
 187     error>> summary ;
 188
 189 M: parse-error compute-restarts
 190     error>> compute-restarts ;
 191
 192 M: parse-error error-help
 193     error>> error-help ;
 194
 195 SYMBOL: use
 196 SYMBOL: in
 197
 198 : word/vocab% ( word -- )
 199     "(" % dup word-vocabulary % " " % word-name % ")" % ;
 200
 201 : (use+) ( vocab -- )
 202     vocab-words use get push ;
 203
 204 : use+ ( vocab -- )
 205     load-vocab (use+) ;
 206
 207 : add-use ( seq -- ) [ use+ ] each ;
 208
 209 : set-use ( seq -- )
 210     [ vocab-words ] V{ } map-as sift use set ;
 211
 212 : check-vocab-string ( name -- name )
 213     dup string?
 214     [ "Vocabulary name must be a string" throw ] unless ;
 215
 216 : set-in ( name -- )
 217     check-vocab-string dup in set create-vocab (use+) ;
 218
 219 ERROR: unexpected want got ;
 220
 221 PREDICATE: unexpected-eof < unexpected
 222     unexpected-got not ;
 223
 224 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
 225
 226 : unexpected-eof ( word -- * ) f unexpected ;
 227
 228 : (parse-tokens) ( accum end -- accum )
 229     scan 2dup = [
 230         2drop
 231     ] [
 232         [ pick push (parse-tokens) ] [ unexpected-eof ] if*
 233     ] if ;
 234
 235 : parse-tokens ( end -- seq )
 236     100 <vector> swap (parse-tokens) >array ;
 237
 238 ERROR: no-current-vocab ;
 239
 240 M: no-current-vocab summary ( obj -- )
 241     drop "Not in a vocabulary; IN: form required" ;
 242
 243 : current-vocab ( -- str )
 244     in get [ no-current-vocab ] unless* ;
 245
 246 : create-in ( str -- word )
 247     current-vocab create dup set-word dup save-location ;
 248
 249 : CREATE ( -- word ) scan create-in ;
 250
 251 : CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
 252
 253 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
 254
 255 : create-class-in ( word -- word )
 256     current-vocab create
 257     dup save-class-location
 258     dup predicate-word dup set-word save-location ;
 259
 260 : CREATE-CLASS ( -- word )
 261     scan create-class-in ;
 262
 263 : word-restarts ( possibilities -- restarts )
 264     natural-sort [
 265         [ "Use the word " swap summary append ] keep
 266     ] { } map>assoc ;
 267
 268 TUPLE: no-word-error name ;
 269
 270 M: no-word-error summary
 271     drop "Word not found in current vocabulary search path" ;
 272
 273 : no-word ( name -- newword )
 274     dup no-word-error boa
 275     swap words-named [ forward-reference? not ] filter
 276     word-restarts throw-restarts
 277     dup word-vocabulary (use+) ;
 278
 279 : check-forward ( str word -- word/f )
 280     dup forward-reference? [
 281         drop
 282         use get
 283         [ at ] with map sift
 284         [ forward-reference? not ] find nip
 285     ] [
 286         nip
 287     ] if ;
 288
 289 : search ( str -- word/f )
 290     dup use get assoc-stack check-forward ;
 291
 292 : scan-word ( -- word/number/f )
 293     scan dup [
 294         dup search [ ] [
 295             dup string>number [ ] [ no-word ] ?if
 296         ] ?if
 297     ] when ;
 298
 299 : create-method-in ( class generic -- method )
 300     create-method f set-word dup save-location ;
 301
 302 : CREATE-METHOD ( -- method )
 303     scan-word bootstrap-word scan-word create-method-in ;
 304
 305 : shadowed-slots ( superclass slots -- shadowed )
 306     >r all-slot-names r> intersect ;
 307
 308 : check-slot-shadowing ( class superclass slots -- )
 309     shadowed-slots [
 310         [
 311             "Definition of slot ``" %
 312             %
 313             "'' in class ``" %
 314             word-name %
 315             "'' shadows a superclass slot" %
 316         ] "" make note.
 317     ] with each ;
 318
 319 ERROR: invalid-slot-name name ;
 320
 321 M: invalid-slot-name summary
 322     drop
 323     "Invalid slot name" ;
 324
 325 : (parse-tuple-slots) ( -- )
 326     #! This isn't meant to enforce any kind of policy, just
 327     #! to check for mistakes of this form:
 328     #!
 329     #! TUPLE: blahblah foo bing
 330     #!
 331     #! : ...
 332     scan {
 333         { [ dup not ] [ unexpected-eof ] }
 334         { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
 335         { [ dup ";" = ] [ drop ] }
 336         [ , (parse-tuple-slots) ]
 337     } cond ;
 338
 339 : parse-tuple-slots ( -- seq )
 340     [ (parse-tuple-slots) ] { } make ;
 341
 342 : parse-tuple-definition ( -- class superclass slots )
 343     CREATE-CLASS
 344     scan {
 345         { ";" [ tuple f ] }
 346         { "<" [ scan-word parse-tuple-slots ] }
 347         [ >r tuple parse-tuple-slots r> prefix ]
 348     } case 3dup check-slot-shadowing ;
 349
 350 ERROR: not-in-a-method-error ;
 351
 352 M: not-in-a-method-error summary
 353     drop "call-next-method can only be called in a method definition" ;
 354
 355 ERROR: staging-violation word ;
 356
 357 M: staging-violation summary
 358     drop
 359     "A parsing word cannot be used in the same file it is defined in." ;
 360
 361 : execute-parsing ( word -- )
 362     [ changed-definitions get key? [ staging-violation ] when ]
 363     [ execute ]
 364     bi ;
 365
 366 : parse-step ( accum end -- accum ? )
 367     scan-word {
 368         { [ 2dup eq? ] [ 2drop f ] }
 369         { [ dup not ] [ drop unexpected-eof t ] }
 370         { [ dup delimiter? ] [ unexpected t ] }
 371         { [ dup parsing-word? ] [ nip execute-parsing t ] }
 372         [ pick push drop t ]
 373     } cond ;
 374
 375 : (parse-until) ( accum end -- accum )
 376     dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
 377
 378 : parse-until ( end -- vec )
 379     100 <vector> swap (parse-until) ;
 380
 381 : parsed ( accum obj -- accum ) over push ;
 382
 383 : with-parser ( lexer quot -- newquot )
 384     swap lexer set
 385     [ call >quotation ] [ <parse-error> rethrow ] recover ;
 386
 387 : (parse-lines) ( lexer -- quot )
 388     [ f parse-until ] with-parser ;
 389
 390 SYMBOL: lexer-factory
 391
 392 [ <lexer> ] lexer-factory set-global
 393
 394 : parse-lines ( lines -- quot )
 395     lexer-factory get call (parse-lines) ;
 396
 397 ! Parsing word utilities
 398 : parse-effect ( end -- effect )
 399     parse-tokens dup { "(" "((" } intersect empty? [
 400         { "--" } split1 dup [
 401             <effect>
 402         ] [
 403             "Stack effect declaration must contain --" throw
 404         ] if
 405     ] [
 406         "Stack effect declaration must not contain ( or ((" throw
 407     ] if ;
 408
 409 ERROR: bad-number ;
 410
 411 : parse-base ( parsed base -- parsed )
 412     scan swap base> [ bad-number ] unless* parsed ;
 413
 414 : parse-literal ( accum end quot -- accum )
 415     >r parse-until r> call parsed ; inline
 416
 417 : parse-definition ( -- quot )
 418     \ ; parse-until >quotation ;
 419
 420 : (:) ( -- word def ) CREATE-WORD parse-definition ;
 421
 422 SYMBOL: current-class
 423 SYMBOL: current-generic
 424
 425 : with-method-definition ( quot -- parsed )
 426     [
 427         >r
 428         [ "method-class" word-prop current-class set ]
 429         [ "method-generic" word-prop current-generic set ]
 430         [ ] tri
 431         r> call
 432     ] with-scope ; inline
 433
 434 : (M:) ( method def -- )
 435     CREATE-METHOD [ parse-definition ] with-method-definition ;
 436
 437 : scan-object ( -- object )
 438     scan-word dup parsing-word?
 439     [ V{ } clone swap execute first ] when ;
 440
 441 GENERIC: expected>string ( obj -- str )
 442
 443 M: f expected>string drop "end of input" ;
 444 M: word expected>string word-name ;
 445 M: string expected>string ;
 446
 447 M: unexpected error.
 448     "Expected " write
 449     dup unexpected-want expected>string write
 450     " but got " write
 451     unexpected-got expected>string print ;
 452
 453 M: bad-number summary
 454     drop "Bad number literal" ;
 455
 456 SYMBOL: bootstrap-syntax
 457
 458 : with-file-vocabs ( quot -- )
 459     [
 460         f in set { "syntax" } set-use
 461         bootstrap-syntax get [ use get push ] when*
 462         call
 463     ] with-scope ; inline
 464
 465 SYMBOL: interactive-vocabs
 466
 467 {
 468     "accessors"
 469     "arrays"
 470     "assocs"
 471     "combinators"
 472     "compiler.errors"
 473     "continuations"
 474     "debugger"
 475     "definitions"
 476     "editors"
 477     "generic"
 478     "help"
 479     "inspector"
 480     "io"
 481     "io.files"
 482     "kernel"
 483     "listener"
 484     "math"
 485     "memory"
 486     "namespaces"
 487     "prettyprint"
 488     "sequences"
 489     "slicing"
 490     "sorting"
 491     "strings"
 492     "syntax"
 493     "tools.annotations"
 494     "tools.crossref"
 495     "tools.memory"
 496     "tools.profiler"
 497     "tools.test"
 498     "tools.threads"
 499     "tools.time"
 500     "tools.vocabs"
 501     "vocabs"
 502     "vocabs.loader"
 503     "words"
 504     "scratchpad"
 505 } interactive-vocabs set-global
 506
 507 : with-interactive-vocabs ( quot -- )
 508     [
 509         "scratchpad" in set
 510         interactive-vocabs get set-use
 511         call
 512     ] with-scope ; inline
 513
 514 : parse-fresh ( lines -- quot )
 515     [ parse-lines ] with-file-vocabs ;
 516
 517 : parsing-file ( file -- )
 518     "quiet" get [
 519         drop
 520     ] [
 521         "Loading " write <pathname> . flush
 522     ] if ;
 523
 524 : filter-moved ( assoc1 assoc2 -- seq )
 525     swap assoc-diff [
 526         drop where dup [ first ] when
 527         file get source-file-path =
 528     ] assoc-filter keys ;
 529
 530 : removed-definitions ( -- assoc1 assoc2 )
 531     new-definitions old-definitions
 532     [ get first2 assoc-union ] bi@ ;
 533
 534 : removed-classes ( -- assoc1 assoc2 )
 535     new-definitions old-definitions
 536     [ get second ] bi@ ;
 537
 538 : forget-removed-definitions ( -- )
 539     removed-definitions filter-moved forget-all ;
 540
 541 : reset-removed-classes ( -- )
 542     removed-classes
 543     filter-moved [ class? ] filter [ reset-class ] each ;
 544
 545 : fix-class-words ( -- )
 546     #! If a class word had a compound definition which was
 547     #! removed, it must go back to being a symbol.
 548     new-definitions get first2
 549     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 550
 551 : forget-smudged ( -- )
 552     forget-removed-definitions
 553     reset-removed-classes
 554     fix-class-words ;
 555
 556 : finish-parsing ( lines quot -- )
 557     file get
 558     [ record-form ]
 559     [ record-definitions ]
 560     [ record-checksum ]
 561     tri ;
 562
 563 : parse-stream ( stream name -- quot )
 564     [
 565         [
 566             lines dup parse-fresh
 567             tuck finish-parsing
 568             forget-smudged
 569         ] with-source-file
 570     ] with-compilation-unit ;
 571
 572 : parse-file-restarts ( file -- restarts )
 573     "Load " swap " again" 3append t 2array 1array ;
 574
 575 : parse-file ( file -- quot )
 576     [
 577         [
 578             [ parsing-file ] keep
 579             [ utf8 <file-reader> ] keep
 580             parse-stream
 581         ] with-compiler-errors
 582     ] [
 583         over parse-file-restarts rethrow-restarts
 584         drop parse-file
 585     ] recover ;
 586
 587 : run-file ( file -- )
 588     [ dup parse-file call ] assert-depth drop ;
 589
 590 : ?run-file ( path -- )
 591     dup exists? [ run-file ] [ drop ] if ;
 592
 593 : bootstrap-file ( path -- )
 594     [ parse-file % ] [ run-file ] if-bootstrapping ;
 595
 596 : eval ( str -- )
 597     [ string-lines parse-fresh ] with-compilation-unit call ;
 598
 599 : eval>string ( str -- output )
 600     [
 601         parser-notes off
 602         [ [ eval ] keep ] try drop
 603     ] with-string-writer ;