library/platform/native/parser.factor

   1 !:folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: parser
  29 USE: arithmetic
  30 USE: combinators
  31 USE: errors
  32 USE: kernel
  33 USE: lists
  34 USE: logic
  35 USE: namespaces
  36 USE: stack
  37 USE: strings
  38 USE: words
  39 USE: vocabularies
  40 USE: unparser
  41
  42 ! Number parsing
  43
  44 : letter? #\a #\z between? ;
  45 : LETTER? #\A #\Z between? ;
  46 : digit? #\0 #\9 between? ;
  47
  48 : not-a-number "Not a number" throw ;
  49
  50 : digit> ( ch -- n )
  51     [
  52         [ digit? ] [ #\0 - ]
  53         [ letter? ] [ #\a - 10 + ]
  54         [ LETTER? ] [ #\A - 10 + ]
  55         [ drop t ] [ not-a-number ]
  56     ] cond ;
  57
  58 : >digit ( n -- ch )
  59     dup 10 < [ #\0 + ] [ 10 - #\a + ] ifte ;
  60
  61 : digit ( num digit -- num )
  62     "base" get swap 2dup >= [
  63         >r * r> +
  64     ] [
  65         not-a-number
  66     ] ifte ;
  67
  68 : (str>fixnum) ( str -- num )
  69     0 swap [ digit> digit ] str-each ;
  70
  71 : str>fixnum ( str -- num )
  72     #! Parse a string representation of an integer.
  73     dup str-length 0 = [
  74         drop not-a-number
  75     ] [
  76         dup "-" str-head? dup [
  77             nip str>fixnum neg
  78         ] [
  79             drop (str>fixnum)
  80         ] ifte
  81     ] ifte ;
  82
  83 ! The parser uses a number of variables:
  84 ! line - the line being parsed
  85 ! pos  - position in the line
  86 ! use  - list of vocabularies
  87 ! in   - vocabulary for new words
  88 !
  89 ! When a token is scanned, it is searched for in the 'use' list
  90 ! of vocabularies. If it is a parsing word, it is executed
  91 ! immediately. Otherwise it is appended to the parse tree.
  92
  93 : parsing? ( word -- ? )
  94     dup word? [
  95         "parsing" swap word-property
  96     ] [
  97         drop f
  98     ] ifte ;
  99
 100 : parsing ( -- ) t "parsing" word set-word-property ;
 101
 102 : <parsing "line" set 0 "pos" set ;
 103 : parsing> "line" off "pos" off ;
 104 : end? ( -- ? ) "pos" get "line" get str-length >= ;
 105 : ch ( -- ch ) "pos" get "line" get str-nth ;
 106 : advance ( -- ) "pos" succ@ ;
 107
 108 : ch-blank? ( -- ? ) end? [ f ] [ ch blank? ] ifte ;
 109 : skip-blank ( -- ) [ ch-blank? ] [ advance ] while ;
 110 : ch-word? ( -- ? ) end? [ f ] [ ch blank? not ] ifte ;
 111 : skip-word ( -- ) [ ch-word? ] [ advance ] while ;
 112
 113 : ch-dispatch? ( -- ? )
 114     #! Hard-coded for now. Make this customizable later.
 115     #! A 'dispatch' is a character that is treated as its
 116     #! own word, eg:
 117     #!
 118     #! "hello world"
 119     #!
 120     #! Will call the parsing word ".
 121     ch "\"!" str-contains? ;
 122
 123 : (scan) ( -- start end )
 124     skip-blank "pos" get
 125     end? [
 126         dup
 127     ] [
 128         ch-dispatch? [ advance ] [ skip-word ] ifte "pos" get
 129     ] ifte ;
 130
 131 : scan ( -- str )
 132     (scan) 2dup = [ 2drop f ] [ "line" get substring ] ifte ;
 133
 134 : parse-word ( str -- obj )
 135     dup "use" get search dup [
 136         nip
 137     ] [
 138         drop str>fixnum
 139     ] ifte ;
 140
 141 : parsed| ( obj -- )
 142     #! Some ugly ugly code to handle [ a | b ] expressions.
 143     >r dup nreverse last* r> swap rplacd swons ;
 144
 145 : expect-] ( -- )
 146     scan "]" = not [ "Expected ]" throw ] when ;
 147
 148 : parsed ( obj -- )
 149     over "|" = [ nip parsed| expect-] ] [ swons ] ifte ;
 150
 151 : number, ( num -- )
 152     str>fixnum parsed ;
 153
 154 : word, ( str -- )
 155     [
 156         parse-word dup parsing? [ execute ] [ parsed ] ifte
 157     ] when* ;
 158
 159 : (parse) <parsing [ end? not ] [ scan word, ] while parsing> ;
 160
 161 : parse ( str -- code )
 162     #! Parse the string into a parse tree that can be executed.
 163     f swap (parse) nreverse ;
 164
 165 : eval ( "X" -- X )
 166     parse call ;
 167
 168 !!! Used by parsing words
 169 : ch-search ( ch -- index )
 170     "pos" get "line" get rot index-of* ;
 171
 172 : (until) ( index -- str )
 173     "pos" get swap dup succ "pos" set "line" get substring ;
 174
 175 : until ( ch -- str )
 176     ch-search (until) ;
 177
 178 : until-eol ( ch -- str )
 179     "line" get str-length (until) ;
 180
 181 : next-ch ( -- ch )
 182     end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ;
 183
 184 !!! Parsing words. 'builtins' is a stupid vocabulary name now
 185 !!! that it does not contain Java words anymore!
 186
 187 IN: builtins
 188
 189 ! Constants
 190 : t t parsed ; parsing
 191 : f f parsed ; parsing
 192
 193 ! Lists
 194 : [ f ; parsing
 195 : ] nreverse parsed ; parsing
 196
 197 : | ( syntax: | cdr ] )
 198     #! See the word 'parsed'. We push a special sentinel, and
 199     #! 'parsed' acts accordingly.
 200     "|" ; parsing
 201
 202 ! Colon defs
 203 : :
 204     #! Begin a word definition. Word name follows.
 205     scan "in" get create f ; parsing
 206
 207 : ;
 208     #! End a word definition.
 209     nreverse define ; parsing
 210
 211 ! Vocabularies
 212 : DEFER: scan "in" get create drop ; parsing
 213 : USE: scan "use" cons@ ; parsing
 214 : IN: scan dup "use" cons@ "in" set ; parsing
 215
 216 ! \x
 217 : escape ( ch -- esc )
 218     [
 219         [ #\e | #\\e ]
 220         [ #\n | #\\n ]
 221         [ #\r | #\\r ]
 222         [ #\t | #\\t ]
 223         [ #\s | #\\s ]
 224         [ #\\s | #\\s ]
 225         [ #\0 | #\\0 ]
 226         [ #\\\ | #\\\ ]
 227         [ #\\" | #\\" ]
 228     ] assoc ;
 229
 230 ! String literal
 231
 232 : parse-escape ( -- )
 233     next-ch escape dup [ % ] [ drop "Bad escape" throw ] ifte ;
 234
 235 : parse-string ( -- )
 236     next-ch dup #\" = [
 237         drop
 238     ] [
 239         dup #\\\ = [ drop parse-escape ] [ % ] ifte parse-string
 240     ] ifte ;
 241
 242 : "
 243     #! Note the ugly hack to carry the new value of 'pos' from
 244     #! the <% %> scope up to the original scope.
 245     <% parse-string "pos" get %> swap "pos" set parsed ; parsing
 246
 247 ! Comments
 248 : ( ")" until drop ; parsing
 249 : ! until-eol drop ; parsing
 250 : #! until-eol drop ; parsing
 251
 252 ! Reading numbers in other bases
 253
 254 : BASE: ( base -- )
 255     #! Read a number in a specific base.
 256     "base" get >r "base" set scan number, r> "base" set ;
 257
 258 : HEX: 16 BASE: ; parsing
 259 : DEC: 10 BASE: ; parsing
 260 : OCT: 8 BASE: ; parsing
 261 : BIN: 2 BASE: ; parsing