core/syntax/syntax.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien arrays byte-arrays byte-vectors
   4 definitions generic hashtables kernel math namespaces parser
   5 lexer sequences strings strings.parser sbufs vectors
   6 words quotations io assocs splitting classes.tuple
   7 generic.standard generic.math generic.parser classes io.files
   8 vocabs classes.parser classes.union
   9 classes.intersection classes.mixin classes.predicate
  10 classes.singleton classes.tuple.parser compiler.units
  11 combinators effects.parser slots ;
  12 IN: bootstrap.syntax
  13
  14 ! These words are defined as a top-level form, instead of with
  15 ! defining parsing words, because during stage1 bootstrap, the
  16 ! "syntax" vocabulary is copied from the host. When stage1
  17 ! bootstrap completes, the host's syntax vocabulary is deleted
  18 ! from the target, then this top-level form creates the
  19 ! target's "syntax" vocabulary as one of the first things done
  20 ! in stage2.
  21
  22 : define-delimiter ( name -- )
  23     "syntax" lookup t "delimiter" set-word-prop ;
  24
  25 : define-syntax ( name quot -- )
  26     >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
  27
  28 [
  29     { "]" "}" ";" ">>" } [ define-delimiter ] each
  30
  31     "PRIMITIVE:" [
  32         "Primitive definition is not supported" throw
  33     ] define-syntax
  34
  35     "CS{" [
  36         "Call stack literals are not supported" throw
  37     ] define-syntax
  38
  39     "!" [ lexer get next-line ] define-syntax
  40
  41     "#!" [ POSTPONE: ! ] define-syntax
  42
  43     "IN:" [ scan set-in ] define-syntax
  44
  45     "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
  46
  47     "<PRIVATE" [
  48         POSTPONE: PRIVATE> in get ".private" append set-in
  49     ] define-syntax
  50
  51     "USE:" [ scan use+ ] define-syntax
  52
  53     "USING:" [ ";" parse-tokens add-use ] define-syntax
  54
  55     "HEX:" [ 16 parse-base ] define-syntax
  56     "OCT:" [ 8 parse-base ] define-syntax
  57     "BIN:" [ 2 parse-base ] define-syntax
  58
  59     "f" [ f parsed ] define-syntax
  60     "t" "syntax" lookup define-singleton-class
  61
  62     "CHAR:" [
  63         scan {
  64             { [ dup length 1 = ] [ first ] }
  65             { [ "\\" ?head ] [ next-escape drop ] }
  66             [ name>char-hook get call ]
  67         } cond parsed
  68     ] define-syntax
  69
  70     "\"" [ parse-string parsed ] define-syntax
  71
  72     "SBUF\"" [
  73         lexer get skip-blank parse-string >sbuf parsed
  74     ] define-syntax
  75
  76     "P\"" [
  77         lexer get skip-blank parse-string <pathname> parsed
  78     ] define-syntax
  79
  80     "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
  81     "{" [ \ } [ >array ] parse-literal ] define-syntax
  82     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
  83     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
  84     "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
  85     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
  86     "T{" [ parse-tuple-literal parsed ] define-syntax
  87     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
  88
  89     "POSTPONE:" [ scan-word parsed ] define-syntax
  90     "\\" [ scan-word literalize parsed ] define-syntax
  91     "inline" [ word make-inline ] define-syntax
  92     "recursive" [ word make-recursive ] define-syntax
  93     "foldable" [ word make-foldable ] define-syntax
  94     "flushable" [ word make-flushable ] define-syntax
  95     "delimiter" [ word t "delimiter" set-word-prop ] define-syntax
  96     "parsing" [ word t "parsing" set-word-prop ] define-syntax
  97
  98     "SYMBOL:" [
  99         CREATE-WORD define-symbol
 100     ] define-syntax
 101
 102     "DEFER:" [
 103         scan current-vocab create
 104         dup old-definitions get [ delete-at ] with each
 105         set-word
 106     ] define-syntax
 107
 108     ":" [
 109         (:) define
 110     ] define-syntax
 111
 112     "GENERIC:" [
 113         CREATE-GENERIC define-simple-generic
 114     ] define-syntax
 115
 116     "GENERIC#" [
 117         CREATE-GENERIC
 118         scan-word <standard-combination> define-generic
 119     ] define-syntax
 120
 121     "MATH:" [
 122         CREATE-GENERIC
 123         T{ math-combination } define-generic
 124     ] define-syntax
 125
 126     "HOOK:" [
 127         CREATE-GENERIC scan-word
 128         <hook-combination> define-generic
 129     ] define-syntax
 130
 131     "M:" [
 132         (M:) define
 133     ] define-syntax
 134
 135     "UNION:" [
 136         CREATE-CLASS parse-definition define-union-class
 137     ] define-syntax
 138
 139     "INTERSECTION:" [
 140         CREATE-CLASS parse-definition define-intersection-class
 141     ] define-syntax
 142
 143     "MIXIN:" [
 144         CREATE-CLASS define-mixin-class
 145     ] define-syntax
 146
 147     "INSTANCE:" [
 148         location >r
 149         scan-word scan-word 2dup add-mixin-instance
 150         <mixin-instance> r> remember-definition
 151     ] define-syntax
 152
 153     "PREDICATE:" [
 154         CREATE-CLASS
 155         scan "<" assert=
 156         scan-word
 157         parse-definition define-predicate-class
 158     ] define-syntax
 159
 160     "SINGLETON:" [
 161         CREATE-CLASS define-singleton-class
 162     ] define-syntax
 163
 164     "TUPLE:" [
 165         parse-tuple-definition define-tuple-class
 166     ] define-syntax
 167
 168     "SLOT:" [
 169         scan define-protocol-slot
 170     ] define-syntax
 171
 172     "C:" [
 173         CREATE-WORD
 174         scan-word [ boa ] curry define-inline
 175     ] define-syntax
 176
 177     "ERROR:" [
 178         parse-tuple-definition
 179         pick save-location
 180         define-error-class
 181     ] define-syntax
 182
 183     "FORGET:" [
 184         scan-object forget
 185     ] define-syntax
 186
 187     "(" [
 188         ")" parse-effect
 189         word dup [ set-stack-effect ] [ 2drop ] if
 190     ] define-syntax
 191
 192     "((" [
 193         "))" parse-effect parsed
 194     ] define-syntax
 195
 196     "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax
 197
 198     "<<" [
 199         [
 200             \ >> parse-until >quotation
 201         ] with-nested-compilation-unit call
 202     ] define-syntax
 203
 204     "call-next-method" [
 205         current-class get current-generic get
 206         2dup [ word? ] both? [
 207             [ literalize parsed ] bi@
 208             \ (call-next-method) parsed
 209         ] [
 210             not-in-a-method-error
 211         ] if
 212     ] define-syntax
 213
 214     "initial:" "syntax" lookup define-symbol
 215
 216     "read-only" "syntax" lookup define-symbol
 217 ] with-compilation-unit