library/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 [ 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 [ 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 -- ) line-text set 0 column set parse-loop ;
  59
  60 TUPLE: bad-escape ;
  61 : bad-escape ( -- * ) <bad-escape> throw ;
  62
  63 ! Parsing word utilities
  64 : escape ( escape -- ch )
  65     H{
  66         { CHAR: e  CHAR: \e }
  67         { CHAR: n  CHAR: \n }
  68         { CHAR: r  CHAR: \r }
  69         { CHAR: t  CHAR: \t }
  70         { CHAR: s  CHAR: \s }
  71         { CHAR: \s CHAR: \s }
  72         { CHAR: 0  CHAR: \0 }
  73         { CHAR: \\ CHAR: \\ }
  74         { CHAR: \" CHAR: \" }
  75     } hash [ bad-escape ] unless* ;
  76
  77 : next-escape ( n str -- n ch )
  78     2dup nth CHAR: u =
  79     [ >r 1+ dup 4 + tuck r> subseq hex> ]
  80     [ over 1+ -rot nth escape ] if ;
  81
  82 : next-char ( n str -- n ch )
  83     2dup nth CHAR: \\ =
  84     [ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
  85
  86 : (parse-string) ( n str -- n )
  87     2dup nth CHAR: " =
  88     [ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
  89
  90 : parse-string ( -- str )
  91     column
  92     [ [ line-text get (parse-string) ] "" make swap ] change ;
  93
  94 : (parse-effect) ( -- )
  95     scan [
  96         dup ")" = [ drop ] [ , (parse-effect) ] if
  97     ] [
  98         "Unexpected EOL" throw
  99     ] if* ;
 100
 101 : parse-effect ( -- effect )
 102     [ (parse-effect) column get ] { } make swap column set
 103     { "--" } split1 <effect> ;
 104
 105 : parse-base ( parsed base -- parsed ) scan swap base> parsed ;
 106
 107 global [
 108     {
 109         "scratchpad" "syntax" "arrays" "compiler" "definitions"
 110         "errors" "generic" "hashtables" "inference"
 111         "io" "kernel" "listener" "math"
 112         "memory" "modules" "namespaces" "parser" "prettyprint"
 113         "sequences" "shells" "strings" "styles" "test"
 114         "threads" "tools" "vectors" "words"
 115     } set-use
 116     "scratchpad" set-in
 117 ] bind