core/syntax/syntax.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays bit-arrays bit-vectors byte-arrays
   4 byte-vectors definitions generic hashtables kernel math
   5 namespaces parser sequences strings sbufs vectors words
   6 quotations io assocs splitting classes.tuple generic.standard
   7 generic.math classes io.files vocabs float-arrays float-vectors
   8 classes.union classes.mixin classes.predicate classes.singleton
   9 compiler.units combinators debugger ;
  10 IN: bootstrap.syntax
  11
  12 ! These words are defined as a top-level form, instead of with
  13 ! defining parsing words, because during stage1 bootstrap, the
  14 ! "syntax" vocabulary is copied from the host. When stage1
  15 ! bootstrap completes, the host's syntax vocabulary is deleted
  16 ! from the target, then this top-level form creates the
  17 ! target's "syntax" vocabulary as one of the first things done
  18 ! in stage2.
  19
  20 : define-delimiter ( name -- )
  21     "syntax" lookup t "delimiter" set-word-prop ;
  22
  23 : define-syntax ( name quot -- )
  24     >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
  25
  26 [
  27     { "]" "}" ";" ">>" } [ define-delimiter ] each
  28
  29     "PRIMITIVE:" [
  30         "Primitive definition is not supported" throw
  31     ] define-syntax
  32
  33     "CS{" [
  34         "Call stack literals are not supported" throw
  35     ] define-syntax
  36
  37     "!" [ lexer get next-line ] define-syntax
  38
  39     "#!" [ POSTPONE: ! ] define-syntax
  40
  41     "IN:" [ scan set-in ] define-syntax
  42
  43     "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax
  44
  45     "<PRIVATE" [
  46         POSTPONE: PRIVATE> in get ".private" append set-in
  47     ] define-syntax
  48
  49     "USE:" [ scan use+ ] define-syntax
  50
  51     "USING:" [ ";" parse-tokens add-use ] define-syntax
  52
  53     "HEX:" [ 16 parse-base ] define-syntax
  54     "OCT:" [ 8 parse-base ] define-syntax
  55     "BIN:" [ 2 parse-base ] define-syntax
  56
  57     "f" [ f parsed ] define-syntax
  58     "t" "syntax" lookup define-singleton-class
  59
  60     "CHAR:" [
  61         scan {
  62             { [ dup length 1 = ] [ first ] }
  63             { [ "\\" ?head ] [ next-escape drop ] }
  64             [ name>char-hook get call ]
  65         } cond parsed
  66     ] define-syntax
  67
  68     "\"" [ parse-string parsed ] define-syntax
  69
  70     "SBUF\"" [
  71         lexer get skip-blank parse-string >sbuf parsed
  72     ] define-syntax
  73
  74     "P\"" [
  75         lexer get skip-blank parse-string <pathname> parsed
  76     ] define-syntax
  77
  78     "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
  79     "{" [ \ } [ >array ] parse-literal ] define-syntax
  80     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
  81     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
  82     "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
  83     "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
  84     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
  85     "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
  86     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
  87
  88     "POSTPONE:" [ scan-word parsed ] define-syntax
  89     "\\" [ scan-word literalize parsed ] define-syntax
  90     "inline" [ word make-inline ] 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 t "parsing" set-word-prop ] define-syntax
  95
  96     "SYMBOL:" [
  97         CREATE-WORD define-symbol
  98     ] define-syntax
  99
 100     "DEFER:" [
 101         scan in get create
 102         dup old-definitions get first delete-at
 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     "MIXIN:" [
 138         CREATE-CLASS define-mixin-class
 139     ] define-syntax
 140
 141     "INSTANCE:" [
 142         location >r
 143         scan-word scan-word 2dup add-mixin-instance
 144         <mixin-instance> r> remember-definition
 145     ] define-syntax
 146
 147     "PREDICATE:" [
 148         CREATE-CLASS
 149         scan "<" assert=
 150         scan-word
 151         parse-definition define-predicate-class
 152     ] define-syntax
 153
 154     "SINGLETON:" [
 155         scan create-class-in
 156         dup save-location define-singleton-class
 157     ] define-syntax
 158
 159     "TUPLE:" [
 160         parse-tuple-definition define-tuple-class
 161     ] define-syntax
 162
 163     "C:" [
 164         CREATE-WORD
 165         scan-word dup check-tuple
 166         [ boa ] curry define-inline
 167     ] define-syntax
 168
 169     "ERROR:" [
 170         parse-tuple-definition
 171         pick save-location
 172         define-error-class
 173     ] define-syntax
 174
 175     "FORGET:" [
 176         scan-object forget
 177     ] define-syntax
 178
 179     "(" [
 180         parse-effect word
 181         [ swap "declared-effect" set-word-prop ] [ drop ] if*
 182     ] define-syntax
 183
 184     "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
 185
 186     "<<" [
 187         [ \ >> parse-until >quotation ] with-compilation-unit
 188         call
 189     ] define-syntax
 190
 191     "call-next-method" [
 192         current-class get literalize parsed
 193         current-generic get literalize parsed
 194         \ (call-next-method) parsed
 195     ] define-syntax
 196 ] with-compilation-unit