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