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.order math.parser namespaces sbufs sequences splitting
   5 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 <PRIVATE
  34
  35 : hex-escape ( str -- ch str' )
  36     2 cut-slice [ hex> ] dip ;
  37
  38 : oct-escape ( str -- ch/f str' )
  39     dup 3 index-or-length head-slice [
  40         [ CHAR: 0 CHAR: 7 between? not ] find drop
  41     ] keep '[ _ length ] unless* [ f ] when-zero
  42     [ cut-slice [ oct> ] dip ] [ f swap ] if* ;
  43
  44 : unicode-escape ( str -- ch str' )
  45     "{" ?head-slice [
  46         CHAR: } over index cut-slice [
  47             dup hex> [
  48                 nip
  49             ] [
  50                 >string name>char-hook get call( name -- char )
  51             ] if*
  52         ] dip rest-slice
  53     ] [
  54         6 cut-slice [ hex> ] dip
  55     ] if ;
  56
  57 : next-escape ( str -- ch str' )
  58     oct-escape over [
  59         nip unclip-slice {
  60             { CHAR: u [ unicode-escape ] }
  61             { CHAR: x [ hex-escape ] }
  62             { CHAR: \n [ f swap ] }
  63             [ escape swap ]
  64         } case
  65     ] unless ;
  66
  67 : (unescape-string) ( accum str i/f -- accum )
  68     { sbuf object object } declare
  69     [
  70         cut-slice [ append! ] dip
  71         rest-slice next-escape [ [ suffix! ] when* ] dip
  72         CHAR: \\ over index (unescape-string)
  73     ] [
  74         append!
  75     ] if* ;
  76
  77 PRIVATE>
  78
  79 : unescape-string ( str -- str' )
  80     CHAR: \\ over index [
  81         [ [ length <sbuf> ] keep ] dip (unescape-string)
  82     ] when* "" like ;
  83
  84 <PRIVATE
  85
  86 : lexer-subseq ( i lexer -- before )
  87     { fixnum lexer } declare
  88     [ [ column>> ] [ line-text>> ] bi swapd subseq ]
  89     [ column<< ] 2bi ;
  90
  91 : rest-of-line ( lexer -- seq )
  92     { lexer } declare
  93     [ line-text>> ] [ column>> ] bi tail-slice ;
  94
  95 : current-char ( lexer -- ch/f )
  96     { lexer } declare
  97     [ column>> ] [ line-text>> ] bi ?nth ;
  98
  99 : advance-char ( lexer -- )
 100     { lexer } declare
 101     [ 1 + ] change-column drop ;
 102
 103 : next-char ( lexer -- ch/f )
 104     { lexer } declare
 105     dup still-parsing-line? [
 106         [ current-char ] [ advance-char ] bi
 107     ] [
 108         drop f
 109     ] if ;
 110
 111 : next-line% ( accum lexer -- )
 112     { sbuf lexer } declare
 113     [ rest-of-line swap push-all ] [ next-line ] bi ;
 114
 115 : find-next-token ( lexer -- i elt )
 116     { lexer } declare
 117     [ column>> ] [ line-text>> ] bi
 118     [ "\"\\" member-eq? ] find-from ;
 119
 120 : check-space ( lexer -- )
 121     dup current-char forbid-tab {
 122         { CHAR: \s [ advance-char ] }
 123         { f [ drop ] }
 124         [ "[space]" swap 1string "'" 1surround unexpected ]
 125     } case ;
 126
 127 DEFER: (parse-string)
 128
 129 : parse-found-token ( accum lexer i elt -- )
 130     { sbuf lexer fixnum fixnum } declare
 131     [ over lexer-subseq pick push-all ] dip
 132     CHAR: \ eq? [
 133         dup dup [ next-char ] bi@
 134         [ [ pick push ] bi@ ]
 135         [ drop 2dup next-line% ] if*
 136         (parse-string)
 137     ] [ dup advance-char check-space drop ] if ;
 138
 139 : (parse-string) ( accum lexer -- )
 140     { sbuf lexer } declare
 141     dup still-parsing? [
 142         dup find-next-token [
 143             parse-found-token
 144         ] [
 145             drop 2dup next-line%
 146             CHAR: \n pick push
 147             (parse-string)
 148         ] if*
 149     ] [
 150         "'\"'" "[eof]" unexpected
 151     ] if ;
 152
 153 PRIVATE>
 154
 155 : parse-string ( -- str )
 156     SBUF" " clone [
 157         lexer get (parse-string)
 158     ] keep unescape-string ;