core/syntax/parser.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: parser
   4 USING: arrays definitions errors generic hashtables kernel math
   5 namespaces prettyprint sequences strings vectors words ;
   6
   7 : skip ( i seq quot -- n )
   8     over >r find* drop dup -1 =
   9     [ drop r> length ] [ r> drop ] if ; inline
  10
  11 : skip-blank ( -- )
  12     column-number [ line-text get [ blank? not ] skip ] change ;
  13
  14 : skip-word ( m line -- n )
  15     2dup nth CHAR: " = [ drop 1+ ] [ [ blank? ] skip ] if ;
  16
  17 : (scan) ( n line -- start end )
  18     dupd 2dup length < [ skip-word ] [ drop ] if ;
  19
  20 : scan ( -- token )
  21     skip-blank
  22     column-number [ line-text get (scan) dup ] change
  23     2dup = [ 2drop f ] [ line-text get subseq ] if ;
  24
  25 : CREATE ( -- word ) scan create-in ;
  26
  27 SYMBOL: string-mode
  28
  29 : do-what-i-mean ( string -- restarts )
  30     words-named natural-sort [
  31         [ "Use the word " swap summary append ] keep 2array
  32     ] map ;
  33
  34 TUPLE: no-word name ;
  35
  36 : no-word ( name -- word )
  37     dup <no-word> swap do-what-i-mean condition ;
  38
  39 : search ( str -- word )
  40     dup use get hash-stack [ ] [
  41         no-word dup word-vocabulary use+
  42     ] ?if ;
  43
  44 : scan-word ( -- obj )
  45     scan dup [
  46         dup ";" = not string-mode get and [
  47             dup string>number [ ] [ search ] ?if
  48         ] unless
  49     ] when ;
  50
  51 : parsed ( parse-tree obj -- parse-tree ) swap ?push ;
  52
  53 : parse-loop ( -- )
  54     scan-word [
  55         dup parsing? [ execute ] [ parsed ] if  parse-loop
  56     ] when* ;
  57
  58 : (parse) ( str -- )
  59     line-text set
  60     line-number inc
  61     0 column-number set
  62     parse-loop ;
  63
  64 TUPLE: bad-escape ;
  65 : bad-escape ( -- * ) <bad-escape> throw ;
  66
  67 ! Parsing word utilities
  68 : escape ( escape -- ch )
  69     H{
  70         { CHAR: e  CHAR: \e }
  71         { CHAR: n  CHAR: \n }
  72         { CHAR: r  CHAR: \r }
  73         { CHAR: t  CHAR: \t }
  74         { CHAR: s  CHAR: \s }
  75         { CHAR: \s CHAR: \s }
  76         { CHAR: 0  CHAR: \0 }
  77         { CHAR: \\ CHAR: \\ }
  78         { CHAR: \" CHAR: \" }
  79     } hash [ bad-escape ] unless* ;
  80
  81 : next-escape ( n str -- n ch )
  82     2dup nth CHAR: u =
  83     [ >r 1+ dup 4 + tuck r> subseq hex> ]
  84     [ over 1+ -rot nth escape ] if ;
  85
  86 : next-char ( n str -- n ch )
  87     2dup nth CHAR: \\ =
  88     [ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
  89
  90 : (parse-string) ( n str -- n )
  91     2dup nth CHAR: " =
  92     [ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
  93
  94 : parse-string ( -- str )
  95     column-number
  96     [ [ line-text get (parse-string) ] "" make swap ] change ;
  97
  98 : (parse-effect) ( -- )
  99     scan [
 100         dup ")" = [ drop ] [ , (parse-effect) ] if
 101     ] [
 102         "Unexpected EOL" throw
 103     ] if* ;
 104
 105 : string>effect ( seq -- effect )
 106     { "--" } split1 dup [
 107         <effect>
 108     ] [
 109         "Stack effect declaration must contain --" throw
 110     ] if ;
 111
 112 : parse-effect ( -- effect )
 113     [ (parse-effect) column-number get ] { } make
 114     swap column-number set
 115     string>effect ;
 116
 117 : parse-base ( parsed base -- parsed ) scan swap base> parsed ;
 118
 119 global [
 120     {
 121         "scratchpad" "syntax" "arrays" "definitions"
 122         "errors" "generic" "hashtables" "help" "inference"
 123         "io" "kernel" "listener" "math" "memory" "modules"
 124         "namespaces" "parser" "prettyprint" "sequences" "shells"
 125         "strings" "styles" "tools" "vectors" "words"
 126     } set-use
 127     "scratchpad" set-in
 128 ] bind