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