core/strings/parser/parser.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel assocs namespaces make splitting sequences
   4 strings math.parser lexer accessors ;
   5 IN: strings.parser
   6
   7 ERROR: bad-escape ;
   8
   9 : escape ( escape -- ch )
  10     H{
  11         { CHAR: a  CHAR: \a }
  12         { CHAR: e  CHAR: \e }
  13         { CHAR: n  CHAR: \n }
  14         { CHAR: r  CHAR: \r }
  15         { CHAR: t  CHAR: \t }
  16         { CHAR: s  CHAR: \s }
  17         { CHAR: \s CHAR: \s }
  18         { CHAR: 0  CHAR: \0 }
  19         { CHAR: \\ CHAR: \\ }
  20         { CHAR: \" CHAR: \" }
  21     } at [ bad-escape ] unless* ;
  22
  23 SYMBOL: name>char-hook
  24
  25 name>char-hook global [
  26     [ "Unicode support not available" throw ] or
  27 ] change-at
  28
  29 : unicode-escape ( str -- ch str' )
  30     "{" ?head-slice [
  31         CHAR: } over index cut-slice
  32         [ >string name>char-hook get call ] dip
  33         rest-slice
  34     ] [
  35         6 cut-slice [ hex> ] dip
  36     ] if ;
  37
  38 : next-escape ( str -- ch str' )
  39     "u" ?head-slice [
  40         unicode-escape
  41     ] [
  42         unclip-slice escape swap
  43     ] if ;
  44
  45 : (parse-string) ( str -- m )
  46     dup [ "\"\\" member? ] find dup [
  47         [ cut-slice [ % ] dip rest-slice ] dip
  48         dup CHAR: " = [
  49             drop from>>
  50         ] [
  51             drop next-escape [ , ] dip (parse-string)
  52         ] if
  53     ] [
  54         "Unterminated string" throw
  55     ] if ;
  56
  57 : parse-string ( -- str )
  58     lexer get [
  59         [ swap tail-slice (parse-string) ] "" make swap
  60     ] change-lexer-column ;
  61
  62 : (unescape-string) ( str -- str' )
  63     dup [ CHAR: \\ = ] find [
  64         cut-slice [ % ] dip rest-slice
  65         next-escape [ , ] dip
  66         (unescape-string)
  67     ] [
  68         drop %
  69     ] if ;
  70
  71 : unescape-string ( str -- str' )
  72     [ (unescape-string) ] "" make ;