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 definitions generic
   4 hashtables kernel math namespaces parser lexer sequences strings
   5 strings.parser sbufs vectors words words.symbol words.constant
   6 words.alias quotations io assocs splitting classes.tuple
   7 generic.standard generic.math generic.parser classes
   8 io.pathnames vocabs vocabs.parser 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     [ dup "syntax" lookup [ dup ] [ no-word-error ] ?if ] dip
  27     define make-parsing ;
  28
  29 [
  30     { "]" "}" ";" ">>" } [ define-delimiter ] each
  31
  32     "PRIMITIVE:" [
  33         "Primitive definition is not supported" throw
  34     ] define-syntax
  35
  36     "CS{" [
  37         "Call stack literals are not supported" throw
  38     ] define-syntax
  39
  40     "!" [ lexer get next-line ] define-syntax
  41
  42     "#!" [ POSTPONE: ! ] define-syntax
  43
  44     "IN:" [ scan set-in ] define-syntax
  45
  46     "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
  47
  48     "<PRIVATE" [
  49         POSTPONE: PRIVATE> in get ".private" append set-in
  50     ] define-syntax
  51
  52     "USE:" [ scan use+ ] define-syntax
  53
  54     "USING:" [ ";" parse-tokens add-use ] define-syntax
  55
  56     "QUALIFIED:" [ scan dup add-qualified ] define-syntax
  57
  58     "QUALIFIED-WITH:" [ scan scan add-qualified ] define-syntax
  59
  60     "FROM:" [
  61         scan "=>" expect ";" parse-tokens swap add-words-from
  62     ] define-syntax
  63
  64     "EXCLUDE:" [
  65         scan "=>" expect ";" parse-tokens swap add-words-excluding
  66     ] define-syntax
  67
  68     "RENAME:" [
  69         scan scan "=>" expect scan add-renamed-word
  70     ] define-syntax
  71
  72     "HEX:" [ 16 parse-base ] define-syntax
  73     "OCT:" [ 8 parse-base ] define-syntax
  74     "BIN:" [ 2 parse-base ] define-syntax
  75
  76     "f" [ f parsed ] define-syntax
  77     "t" "syntax" lookup define-singleton-class
  78
  79     "CHAR:" [
  80         scan {
  81             { [ dup length 1 = ] [ first ] }
  82             { [ "\\" ?head ] [ next-escape >string "" assert= ] }
  83             [ name>char-hook get call ]
  84         } cond parsed
  85     ] define-syntax
  86
  87     "\"" [ parse-string parsed ] define-syntax
  88
  89     "SBUF\"" [
  90         lexer get skip-blank parse-string >sbuf parsed
  91     ] define-syntax
  92
  93     "P\"" [
  94         lexer get skip-blank parse-string <pathname> parsed
  95     ] define-syntax
  96
  97     "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
  98     "{" [ \ } [ >array ] parse-literal ] define-syntax
  99     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
 100     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
 101     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
 102     "T{" [ parse-tuple-literal parsed ] define-syntax
 103     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
 104
 105     "POSTPONE:" [ scan-word parsed ] define-syntax
 106     "\\" [ scan-word literalize parsed ] define-syntax
 107     "inline" [ word make-inline ] define-syntax
 108     "recursive" [ word make-recursive ] define-syntax
 109     "foldable" [ word make-foldable ] define-syntax
 110     "flushable" [ word make-flushable ] define-syntax
 111     "delimiter" [ word t "delimiter" set-word-prop ] define-syntax
 112     "parsing" [ word make-parsing ] define-syntax
 113
 114     "SYMBOL:" [
 115         CREATE-WORD define-symbol
 116     ] define-syntax
 117
 118     "SYMBOLS:" [
 119         ";" parse-tokens
 120         [ create-in dup reset-generic define-symbol ] each
 121     ] define-syntax
 122
 123     "SINGLETONS:" [
 124         ";" parse-tokens
 125         [ create-class-in define-singleton-class ] each
 126     ] define-syntax
 127
 128     "ALIAS:" [
 129         CREATE-WORD scan-word define-alias
 130     ] define-syntax
 131
 132     "CONSTANT:" [
 133         CREATE scan-object define-constant
 134     ] define-syntax
 135
 136     "DEFER:" [
 137         scan current-vocab create
 138         dup old-definitions get [ delete-at ] with each
 139         set-word
 140     ] define-syntax
 141
 142     ":" [
 143         (:) define
 144     ] define-syntax
 145
 146     "GENERIC:" [
 147         CREATE-GENERIC define-simple-generic
 148     ] define-syntax
 149
 150     "GENERIC#" [
 151         CREATE-GENERIC
 152         scan-word <standard-combination> define-generic
 153     ] define-syntax
 154
 155     "MATH:" [
 156         CREATE-GENERIC
 157         T{ math-combination } define-generic
 158     ] define-syntax
 159
 160     "HOOK:" [
 161         CREATE-GENERIC scan-word
 162         <hook-combination> define-generic
 163     ] define-syntax
 164
 165     "M:" [
 166         (M:) define
 167     ] define-syntax
 168
 169     "UNION:" [
 170         CREATE-CLASS parse-definition define-union-class
 171     ] define-syntax
 172
 173     "INTERSECTION:" [
 174         CREATE-CLASS parse-definition define-intersection-class
 175     ] define-syntax
 176
 177     "MIXIN:" [
 178         CREATE-CLASS define-mixin-class
 179     ] define-syntax
 180
 181     "INSTANCE:" [
 182         location [
 183             scan-word scan-word 2dup add-mixin-instance
 184             <mixin-instance>
 185         ] dip remember-definition
 186     ] define-syntax
 187
 188     "PREDICATE:" [
 189         CREATE-CLASS
 190         scan "<" assert=
 191         scan-word
 192         parse-definition define-predicate-class
 193     ] define-syntax
 194
 195     "SINGLETON:" [
 196         CREATE-CLASS define-singleton-class
 197     ] define-syntax
 198
 199     "TUPLE:" [
 200         parse-tuple-definition define-tuple-class
 201     ] define-syntax
 202
 203     "SLOT:" [
 204         scan define-protocol-slot
 205     ] define-syntax
 206
 207     "C:" [
 208         CREATE-WORD scan-word define-boa-word
 209     ] define-syntax
 210
 211     "ERROR:" [
 212         parse-tuple-definition
 213         pick save-location
 214         define-error-class
 215     ] define-syntax
 216
 217     "FORGET:" [
 218         scan-object forget
 219     ] define-syntax
 220
 221     "(" [
 222         ")" parse-effect
 223         word dup [ set-stack-effect ] [ 2drop ] if
 224     ] define-syntax
 225
 226     "((" [
 227         "))" parse-effect parsed
 228     ] define-syntax
 229
 230     "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax
 231
 232     "<<" [
 233         [
 234             \ >> parse-until >quotation
 235         ] with-nested-compilation-unit call
 236     ] define-syntax
 237
 238     "call-next-method" [
 239         current-method get [
 240             literalize parsed
 241             \ (call-next-method) parsed
 242         ] [
 243             not-in-a-method-error
 244         ] if*
 245     ] define-syntax
 246
 247     "initial:" "syntax" lookup define-symbol
 248
 249     "read-only" "syntax" lookup define-symbol
 250 ] with-compilation-unit