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     dup changed-definitions get key? [ staging-violation ] when
 363     execute ;
 364
 365 : parse-step ( accum end -- accum ? )
 366     scan-word {
 367         { [ 2dup eq? ] [ 2drop f ] }
 368         { [ dup not ] [ drop unexpected-eof t ] }
 369         { [ dup delimiter? ] [ unexpected t ] }
 370         { [ dup parsing-word? ] [ nip execute-parsing t ] }
 371         [ pick push drop t ]
 372     } cond ;
 373
 374 : (parse-until) ( accum end -- accum )
 375     dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
 376
 377 : parse-until ( end -- vec )
 378     100 <vector> swap (parse-until) ;
 379
 380 : parsed ( accum obj -- accum ) over push ;
 381
 382 : with-parser ( lexer quot -- newquot )
 383     swap lexer set
 384     [ call >quotation ] [ <parse-error> rethrow ] recover ;
 385
 386 : (parse-lines) ( lexer -- quot )
 387     [ f parse-until ] with-parser ;
 388
 389 SYMBOL: lexer-factory
 390
 391 [ <lexer> ] lexer-factory set-global
 392
 393 : parse-lines ( lines -- quot )
 394     lexer-factory get call (parse-lines) ;
 395
 396 ! Parsing word utilities
 397 : parse-effect ( end -- effect )
 398     parse-tokens dup { "(" "((" } intersect empty? [
 399         { "--" } split1 dup [
 400             <effect>
 401         ] [
 402             "Stack effect declaration must contain --" throw
 403         ] if
 404     ] [
 405         "Stack effect declaration must not contain ( or ((" throw
 406     ] if ;
 407
 408 ERROR: bad-number ;
 409
 410 : parse-base ( parsed base -- parsed )
 411     scan swap base> [ bad-number ] unless* parsed ;
 412
 413 : parse-literal ( accum end quot -- accum )
 414     >r parse-until r> call parsed ; inline
 415
 416 : parse-definition ( -- quot )
 417     \ ; parse-until >quotation ;
 418
 419 : (:) ( -- word def ) CREATE-WORD parse-definition ;
 420
 421 SYMBOL: current-class
 422 SYMBOL: current-generic
 423
 424 : with-method-definition ( quot -- parsed )
 425     [
 426         >r
 427         [ "method-class" word-prop current-class set ]
 428         [ "method-generic" word-prop current-generic set ]
 429         [ ] tri
 430         r> call
 431     ] with-scope ; inline
 432
 433 : (M:) ( method def -- )
 434     CREATE-METHOD [ parse-definition ] with-method-definition ;
 435
 436 : scan-object ( -- object )
 437     scan-word dup parsing-word?
 438     [ V{ } clone swap execute first ] when ;
 439
 440 GENERIC: expected>string ( obj -- str )
 441
 442 M: f expected>string drop "end of input" ;
 443 M: word expected>string word-name ;
 444 M: string expected>string ;
 445
 446 M: unexpected error.
 447     "Expected " write
 448     dup unexpected-want expected>string write
 449     " but got " write
 450     unexpected-got expected>string print ;
 451
 452 M: bad-number summary
 453     drop "Bad number literal" ;
 454
 455 SYMBOL: bootstrap-syntax
 456
 457 : with-file-vocabs ( quot -- )
 458     [
 459         f in set { "syntax" } set-use
 460         bootstrap-syntax get [ use get push ] when*
 461         call
 462     ] with-scope ; inline
 463
 464 SYMBOL: interactive-vocabs
 465
 466 {
 467     "accessors"
 468     "arrays"
 469     "assocs"
 470     "combinators"
 471     "compiler.errors"
 472     "continuations"
 473     "debugger"
 474     "definitions"
 475     "editors"
 476     "generic"
 477     "help"
 478     "inspector"
 479     "io"
 480     "io.files"
 481     "kernel"
 482     "listener"
 483     "math"
 484     "memory"
 485     "namespaces"
 486     "prettyprint"
 487     "sequences"
 488     "slicing"
 489     "sorting"
 490     "strings"
 491     "syntax"
 492     "tools.annotations"
 493     "tools.crossref"
 494     "tools.memory"
 495     "tools.profiler"
 496     "tools.test"
 497     "tools.threads"
 498     "tools.time"
 499     "tools.vocabs"
 500     "vocabs"
 501     "vocabs.loader"
 502     "words"
 503     "scratchpad"
 504 } interactive-vocabs set-global
 505
 506 : with-interactive-vocabs ( quot -- )
 507     [
 508         "scratchpad" in set
 509         interactive-vocabs get set-use
 510         call
 511     ] with-scope ; inline
 512
 513 : parse-fresh ( lines -- quot )
 514     [ parse-lines ] with-file-vocabs ;
 515
 516 : parsing-file ( file -- )
 517     "quiet" get [
 518         drop
 519     ] [
 520         "Loading " write <pathname> . flush
 521     ] if ;
 522
 523 : filter-moved ( assoc1 assoc2 -- seq )
 524     swap assoc-diff [
 525         drop where dup [ first ] when
 526         file get source-file-path =
 527     ] assoc-filter keys ;
 528
 529 : removed-definitions ( -- assoc1 assoc2 )
 530     new-definitions old-definitions
 531     [ get first2 assoc-union ] bi@ ;
 532
 533 : removed-classes ( -- assoc1 assoc2 )
 534     new-definitions old-definitions
 535     [ get second ] bi@ ;
 536
 537 : forget-removed-definitions ( -- )
 538     removed-definitions filter-moved forget-all ;
 539
 540 : reset-removed-classes ( -- )
 541     removed-classes
 542     filter-moved [ class? ] filter [ reset-class ] each ;
 543
 544 : fix-class-words ( -- )
 545     #! If a class word had a compound definition which was
 546     #! removed, it must go back to being a symbol.
 547     new-definitions get first2
 548     filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
 549
 550 : forget-smudged ( -- )
 551     forget-removed-definitions
 552     reset-removed-classes
 553     fix-class-words ;
 554
 555 : finish-parsing ( lines quot -- )
 556     file get
 557     [ record-form ]
 558     [ record-definitions ]
 559     [ record-checksum ]
 560     tri ;
 561
 562 : parse-stream ( stream name -- quot )
 563     [
 564         [
 565             lines dup parse-fresh
 566             tuck finish-parsing
 567             forget-smudged
 568         ] with-source-file
 569     ] with-compilation-unit ;
 570
 571 : parse-file-restarts ( file -- restarts )
 572     "Load " swap " again" 3append t 2array 1array ;
 573
 574 : parse-file ( file -- quot )
 575     [
 576         [
 577             [ parsing-file ] keep
 578             [ utf8 <file-reader> ] keep
 579             parse-stream
 580         ] with-compiler-errors
 581     ] [
 582         over parse-file-restarts rethrow-restarts
 583         drop parse-file
 584     ] recover ;
 585
 586 : run-file ( file -- )
 587     [ dup parse-file call ] assert-depth drop ;
 588
 589 : ?run-file ( path -- )
 590     dup exists? [ run-file ] [ drop ] if ;
 591
 592 : bootstrap-file ( path -- )
 593     [ parse-file % ] [ run-file ] if-bootstrapping ;
 594
 595 : eval ( str -- )
 596     [ string-lines parse-fresh ] with-compilation-unit call ;
 597
 598 : eval>string ( str -- output )
 599     [
 600         parser-notes off
 601         [ [ eval ] keep ] try drop
 602     ] with-string-writer ;