core/syntax/early-parser.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: parser
   4 USING: arrays errors generic hashtables kernel math namespaces
   5 sequences strings vectors words ;
   6
   7 SYMBOL: use
   8 SYMBOL: in
   9
  10 SYMBOL: file
  11 SYMBOL: line-number
  12
  13 SYMBOL: line-text
  14 SYMBOL: column-number
  15
  16 TUPLE: check-vocab name ;
  17 : check-vocab ( name -- vocab )
  18     dup vocab [ ] [
  19         <check-vocab>
  20         { { "Continue" f } } condition
  21     ] ?if ;
  22
  23 : use+ ( vocab -- ) check-vocab [ use get push ] when* ;
  24
  25 : add-use ( seq -- ) [ use+ ] each ;
  26
  27 : set-use ( seq -- )
  28     [ check-vocab ] map [ ] subset >vector use set ;
  29
  30 : set-in ( name -- )
  31     dup string?
  32     [ "Vocabulary name must be a string" throw ] unless
  33     dup ensure-vocab dup in set use+ ;
  34
  35 : parsing? ( obj -- ? )
  36     dup word? [ "parsing" word-prop ] [ drop f ] if ;
  37
  38 : location ( -- loc )
  39     file get line-number get 2dup and
  40     [ 2array ] [ 2drop f ] if ;
  41
  42 : save-location ( word -- )
  43     dup set-word location "loc" set-word-prop ;
  44
  45 : create-in ( string -- word )
  46     in get create dup save-location ;
  47
  48 : create-constructor ( class -- word )
  49     dup word-name swap word-vocabulary constructor-word
  50     dup save-location ;
  51
  52 TUPLE: parse-error file line col text ;
  53
  54 C: parse-error ( msg -- error )
  55     file get over set-parse-error-file
  56     line-number get over set-parse-error-line
  57     column-number get over set-parse-error-col
  58     line-text get over set-parse-error-text
  59     [ set-delegate ] keep ;