core/strings/parser/parser.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators kernel kernel.private lexer
   4 math math.parser namespaces sbufs sequences splitting strings ;
   5 IN: strings.parser
   6
   7 ERROR: bad-escape char ;
   8
   9 : escape ( escape -- ch )
  10     H{
  11         { CHAR: a  CHAR: \a }
  12         { CHAR: b  CHAR: \b }
  13         { CHAR: e  CHAR: \e }
  14         { CHAR: f  CHAR: \f }
  15         { CHAR: n  CHAR: \n }
  16         { CHAR: r  CHAR: \r }
  17         { CHAR: t  CHAR: \t }
  18         { CHAR: s  CHAR: \s }
  19         { CHAR: v  CHAR: \v }
  20         { CHAR: \s CHAR: \s }
  21         { CHAR: 0  CHAR: \0 }
  22         { CHAR: \\ CHAR: \\ }
  23         { CHAR: \" CHAR: \" }
  24     } ?at [ bad-escape ] unless ;
  25
  26 SYMBOL: name>char-hook
  27
  28 name>char-hook [
  29     [ "Unicode support not available" throw ]
  30 ] initialize
  31
  32 : hex-escape ( str -- ch str' )
  33     2 cut-slice [ hex> ] dip ;
  34
  35 : unicode-escape ( str -- ch str' )
  36     "{" ?head-slice [
  37         CHAR: } over index cut-slice [
  38             dup hex> [
  39                 nip
  40             ] [
  41                 >string name>char-hook get call( name -- char )
  42             ] if*
  43         ] dip rest-slice
  44     ] [
  45         6 cut-slice [ hex> ] dip
  46     ] if ;
  47
  48 : next-escape ( str -- ch str' )
  49     unclip-slice {
  50         { CHAR: u [ unicode-escape ] }
  51         { CHAR: x [ hex-escape ] }
  52         { CHAR: \n [ f swap ] }
  53         [ escape swap ]
  54     } case ;
  55
  56 <PRIVATE
  57
  58 : (unescape-string) ( accum str i/f -- accum )
  59     { sbuf object object } declare
  60     [
  61         cut-slice [ append! ] dip
  62         rest-slice next-escape [ [ suffix! ] when* ] dip
  63         CHAR: \\ over index (unescape-string)
  64     ] [
  65         append!
  66     ] if* ;
  67
  68 PRIVATE>
  69
  70 : unescape-string ( str -- str' )
  71     CHAR: \\ over index [
  72         [ [ length <sbuf> ] keep ] dip (unescape-string)
  73     ] when* "" like ;
  74
  75 <PRIVATE
  76
  77 : lexer-subseq ( i lexer -- before )
  78     { fixnum lexer } declare
  79     [ [ column>> ] [ line-text>> ] bi swapd subseq ]
  80     [ column<< ] 2bi ;
  81
  82 : rest-of-line ( lexer -- seq )
  83     { lexer } declare
  84     [ line-text>> ] [ column>> ] bi tail-slice ;
  85
  86 : current-char ( lexer -- ch/f )
  87     { lexer } declare
  88     [ column>> ] [ line-text>> ] bi ?nth ;
  89
  90 : advance-char ( lexer -- )
  91     { lexer } declare
  92     [ 1 + ] change-column drop ;
  93
  94 : next-char ( lexer -- ch/f )
  95     { lexer } declare
  96     dup still-parsing-line? [
  97         [ current-char ] [ advance-char ] bi
  98     ] [
  99         drop f
 100     ] if ;
 101
 102 : next-line% ( accum lexer -- )
 103     { sbuf lexer } declare
 104     [ rest-of-line swap push-all ] [ next-line ] bi ;
 105
 106 : find-next-token ( lexer -- i elt )
 107     { lexer } declare
 108     [ column>> ] [ line-text>> ] bi
 109     [ "\"\\" member-eq? ] find-from ;
 110
 111 : check-space ( lexer -- )
 112     dup current-char forbid-tab {
 113         { CHAR: \s [ advance-char ] }
 114         { f [ drop ] }
 115         [ "[space]" swap 1string "'" 1surround unexpected ]
 116     } case ;
 117
 118 DEFER: (parse-string)
 119
 120 : parse-found-token ( accum lexer i elt -- )
 121     { sbuf lexer fixnum fixnum } declare
 122     [ over lexer-subseq pick push-all ] dip
 123     CHAR: \ eq? [
 124         dup dup [ next-char ] bi@
 125         [ [ pick push ] bi@ ]
 126         [ drop 2dup next-line% ] if*
 127         (parse-string)
 128     ] [ dup advance-char check-space drop ] if ;
 129
 130 : (parse-string) ( accum lexer -- )
 131     { sbuf lexer } declare
 132     dup still-parsing? [
 133         dup find-next-token [
 134             parse-found-token
 135         ] [
 136             drop 2dup next-line%
 137             CHAR: \n pick push
 138             (parse-string)
 139         ] if*
 140     ] [
 141         "'\"'" "[eof]" unexpected
 142     ] if ;
 143
 144 PRIVATE>
 145
 146 : parse-string ( -- str )
 147     SBUF" " clone [
 148         lexer get (parse-string)
 149     ] keep unescape-string ;