substrate-lang 0.9.3 → 0.10.0

package/substrate/compiler/checker.sub

@@ -8,7 +8,7 @@
 
 ;; ---- uses ----
 
-(struct checking [phase i32] [counter i32] [instances (ptr hash-table)] [throwers (ptr hash-table)]
+(struct checking [phase i32] [counter i32] [throwers (ptr hash-table)]
         [strings (ptr hash-table)] [copies (ptr hash-table)] [layouts (ptr hash-table)] [types (ptr hash-table)]
         [rethrown datum] [datum datum] [next (ptr checking)])
 
@@ -23,9 +23,9 @@
 (define meaning-of (fn (datum) -> datum) 0)
 (define inline-call-of (fn (datum datum) -> datum) 0)
 (define inline-copy-of (fn (datum) -> datum) 0)
-(define expand-head-of (fn (datum bool) -> datum) 0)
-(define scope-shape-of (fn (datum bool) -> datum) 0)
-(define apply-form-of (fn (datum datum bool) -> datum) 0)
+(define expand-head-of (fn (datum) -> datum) 0)
+(define scope-shape-of (fn (datum) -> datum) 0)
+(define apply-form-of (fn (datum datum) -> datum) 0)
 (define prune-local-scopes (fn (datum) -> datum) 0)
 (define facts-of (fn (datum) -> datum) 0)
 (define datum-type-of (fn () -> datum) 0)
@@ -33,8 +33,8 @@
 
 (define (set-expander! [meaning (fn (datum) -> datum)]
                        [inline-call (fn (datum datum) -> datum)] [inline-copy (fn (datum) -> datum)]
-                       [head (fn (datum bool) -> datum)] [shape (fn (datum bool) -> datum)]
-                       [apply (fn (datum datum bool) -> datum)] [prune (fn (datum) -> datum)] [facts (fn (datum) -> datum)]
+                       [head (fn (datum) -> datum)] [shape (fn (datum) -> datum)]
+                       [apply (fn (datum datum) -> datum)] [prune (fn (datum) -> datum)] [facts (fn (datum) -> datum)]
                        [quoted (fn () -> datum)] [syntax-function (fn (datum i32) -> datum)])
   (set! meaning-of meaning)
   (set! inline-call-of inline-call)
@@ -48,12 +48,10 @@
   (set! syntax-function-of syntax-function)
   (set-type-query! local-type-of))
 
-(define twice i32 0)
-
-(define (expand-head [s datum]) -> datum (expand-head-of s (!= twice 0)))
+(define (expand-head [s datum]) -> datum (expand-head-of s))
 (define (expand-in [s datum] [env datum]) -> datum (set! scope-env env) (expand-head s))
-(define (scope-shape! [m datum]) -> datum (scope-shape-of m (!= twice 0)))
-(define (apply-form! [t datum] [s datum]) -> datum (apply-form-of t s (!= twice 0)))
+(define (scope-shape! [m datum]) -> datum (scope-shape-of m))
+(define (apply-form! [t datum] [s datum]) -> datum (apply-form-of t s))
 
 (define (substrate-expansion [kind datum] [env datum] [s datum] [context datum] [states (ptr (ptr void))] [phase i32]) -> datum
   (let ([outer-here here] [outer-state state] [outer-env scope-env] [out datum 0])
@@ -103,18 +101,15 @@
 
 (define (checker-recover!)
   (set! here 0)
-  (set! state 0)
-  (set! twice 0)
-  (set! type-arguments nil))
+  (set! state 0))
 
 (define (state-at [states (ptr (ptr void))] [phase i32]) -> (ptr checking)
   (let ([s (cast (ptr checking) (@ states))])
     (while (and (!= s 0) (!= (-> s phase) phase)) (set! s (-> s next)))
     (when (== s 0)
-      (set! s (cast (ptr checking) (arena-alloc (current-arena) (sizeof checking))))
+      (set! s (new (current-arena) checking))
       (set! (-> s phase) phase)
       (set! (-> s counter) 0)
-      (set! (-> s instances) (make-table))
       (set! (-> s throwers) (make-table))
       (set! (-> s strings) (make-table))
       (set! (-> s copies) (make-table))
@@ -138,6 +133,7 @@
     [('struct) (aggregate-type s 'struct)]
     [('union) (aggregate-type s 'union)]
     [('variant) (substrate-variant s)]
+    [('enum) (substrate-enum s)]
     [('substrate-struct-check) (substrate-struct-check s)]
     [('exception) (substrate-exception s)]
     [('typedef) (substrate-typedef s)]
@@ -145,7 +141,7 @@
     [('#%module-begin) (substrate-module-begin s)]
     [('forms) (forms-form s)]
     [('#%top-interaction) (syntax-match s [(_ e) (at s (syn `(#%checked interaction ,e)))])]
-    [('make-cell 'new) (data-form kind s)]
+    [('make-cell) (data-form s)]
     [('test) (substrate-test s)]
     [('expect) (substrate-expect s)]
     [('expect-equal) (substrate-expect-equal s)]
@@ -169,7 +165,7 @@
 (struct code-record [self datum] [code datum])
 
 (define (code-box [c datum]) -> datum
-  (let ([b (cast (ptr code-record) (arena-alloc (current-arena) (sizeof code-record)))])
+  (let ([b (new (current-arena) code-record)])
     (set! (-> b self) (make-record code-kind b))
     (set! (-> b code) c)
     (-> b self)))
@@ -223,6 +219,7 @@
 (define (closure-type? [t datum]) -> bool (and (pair? t) (== (car t) 'closure)))
 (define (array-type? [t datum]) -> bool (and (pair? t) (== (car t) 'array)))
 (define (struct-type? [t datum]) -> bool (and (pair? t) (== (car t) 'struct)))
+(define (enum-type? [t datum]) -> bool (and (pair? t) (== (car t) 'enum)))
 (define (aggregate? [t datum]) -> bool (or (array-type? t) (struct-type? t)))
 (define (slice-type? [t datum]) -> bool (and (pair? t) (== (car t) 'slice)))
 ;; A string or a slice: a pointer and a length in one i64, the pointer below.
@@ -252,10 +249,7 @@
          `(,(car t) ,(for/list ([u (cadr t)]) (shown-as u full))
            ,@(if (== (caddr t) 'void) nil `(-> ,(shown-as (caddr t) full))))]
         [(array-type? t) `(array ,(shown-as (cadr t) full) ,(caddr t))]
-        [(struct-type? t)
-         (let ([name (if full (cadr t) (caddr t))])
-           (if (pair? (cdddr t)) (cons name (for/list ([u (cadddr t)]) (shown-as u full))) name))]
-        [(and (pair? t) (== (car t) 'tvar)) (cadr t)]
+        [(or (struct-type? t) (enum-type? t)) (if full (cadr t) (caddr t))]
         [(values-type? t) (cons 'values (for/list ([u (cdr t)]) (shown-as u full)))]
         [(== t 'none) 'void]
         [else (settled-type t)]))
@@ -264,25 +258,11 @@
   (let ([a (shown t)] [b (shown u)])
     (if (equal? a b) `(,(shown-as t #t) ,(shown-as u #t)) `(,a ,b))))
 
-(define type-arguments datum nil)
-
-(define (type-variables [ps datum]) -> datum (for/list ([p ps]) (cons p `(tvar ,p))))
-
-(define (parse-types-with [s datum] [ts datum]) -> datum
-  (let ([saved type-arguments] [r datum 0])
-    (set! type-arguments s)
-    (set! r (try (for/list ([t ts]) (parse-type t)) [catch-all (set! type-arguments saved) (rethrow)]))
-    (set! type-arguments saved)
-    r))
-
 (define (parse-type [s datum]) -> datum
   (syntax-match s
     [('quote t) (syntax->datum t)]
     [(? identifier? x)
-     (let ([bound (assq (syntax-e x) type-arguments)])
-       (cond [bound (cdr bound)]
-             [(memq (syntax-e x) '(void i8 u8 i16 u16 i32 u32 i64 u64 f32 f64 exnref bool string)) (syntax-e x)]
-             [else (named-type x)]))]
+     (if (memq (syntax-e x) '(void i8 u8 i16 u16 i32 u32 i64 u64 f32 f64 exnref bool string)) (syntax-e x) (named-type x))]
     [('ptr t) `(ptr ,(parse-type t))]
     [('slice t)
      (let ([u (kept! (parse-type t) t)])
@@ -299,21 +279,11 @@
     [('values t ...)
      (when (null? t) (substrate-error s "expected a type" nil))
      `(values ,@(for/list ([u t]) (scalar! (parse-type u) u)))]
-    [((? identifier? h) a ...) (applied-type s h a)]
     [_ (substrate-error s "expected a type" nil)]))
 
-(define (applied-type [s datum] [h datum] [a datum]) -> datum
-  (let ([v (type-binding h)])
-    (unless (and v (== (car v) 'substrate-struct) (pair? (parameters-of v)))
-      (substrate-error h "~a is not a type that takes types" `(,(syntax-e h))))
-    (unless (== (length a) (length (parameters-of v)))
-      (substrate-error s "~a takes ~a type~a, not ~a"
-                       `(,(syntax-e h) ,(fixnum (length (parameters-of v))) ,(plural (length (parameters-of v))) ,(fixnum (length a)))))
-    `(struct ,(identifier-name h) ,(cadr v) ,(for/list ([t a]) (kept! (complete! (parse-type t) t) t)))))
-
-(define (parameters-of [v datum]) -> datum (if (> (length v) 4) (list-ref v 4) nil))
+(define (numbers-of [v datum]) -> datum (if (> (length v) 4) (list-ref v 4) 0))
 
-;; A type's compile-time value: (substrate-struct name (field ...) kind (parameter ...)) or
+;; A type's compile-time value: (substrate-struct name (field ...) kind), with an enum's case numbers after the kind, or
 ;; (substrate-typedef type).
 (define (type-binding [x datum]) -> datum
   (if (== (identifier-binding-kind x) 'compile-time-value) (type-value (syntax-local-value x)) 0))
@@ -324,7 +294,9 @@
         known
         (let* ([l (syntax->list v)]
                [t datum (syntax-match (if (!= l 0) l nil)
-                    [('substrate-struct n fs k (p ...)) `(substrate-struct ,(syntax-e n) ,fs ,(syntax-e k) ,(for/list ([q p]) (syntax-e q)))]
+                    [('substrate-struct n fs k) `(substrate-struct ,(syntax-e n) ,fs ,(syntax-e k))]
+                    [('substrate-struct n fs k (x ...))
+                     `(substrate-struct ,(syntax-e n) ,fs ,(syntax-e k) ,(for/list ([y x]) (syntax-e y)))]
                     [('substrate-typedef t) `(substrate-typedef ,(syntax->datum t))]
                     [_ 0])])
           (when (!= t 0) (hash-set! (-> state types) (cast u64 v) (cast u32 t)))
@@ -334,22 +306,18 @@
   (let ([v (type-binding x)])
     (when (== v 0) (substrate-error x "~a is not a type" `(,(syntax-e x))))
     (cond [(== (car v) 'substrate-typedef) (cadr v)]
-          [(pair? (parameters-of v)) (substrate-error x "~a takes types: write (~a type ...)" `(,(syntax-e x) ,(syntax-e x)))]
+          [(!= (numbers-of v) 0) `(enum ,(identifier-name x) ,(cadr v))]
           [else `(struct ,(identifier-name x) ,(cadr v))])))
 
 (define (type-syntax? [s datum]) -> bool
   (syntax-match s
     [(? identifier? x) (or (memq (syntax-e x) '(i8 u8 i16 u16 i32 u32 i64 u64 f32 f64 bool string)) (type-binding x))]
     [('slice t) (type-syntax? t)]
-    [((? identifier? h) a ...)
-     (or (memq (syntax-e h) '(ptr array fn closure))
-         (let ([v (type-binding h)])
-           (and v (== (car v) 'substrate-struct) (pair? (parameters-of v))
-                (not (ormap (lambda ([x datum]) -> bool (keyword? (syntax-e x))) a)))))]
+    [((? identifier? h) a ...) (!= (memq (syntax-e h) '(ptr array fn closure)) 0)]
     [_ #f]))
 
 (define (scalar! [t datum] [where datum]) -> datum
-  (unless (or (arithmetic? t) (address-type? t) (== t 'exnref) (== t 'bool) (view-type? t) (and (pair? t) (== (car t) 'tvar)))
+  (unless (or (arithmetic? t) (address-type? t) (== t 'exnref) (== t 'bool) (view-type? t) (enum-type? t))
     (substrate-error where "expected a number or pointer type, not ~s" `(,(shown t))))
   t)
 
@@ -394,15 +362,12 @@
   (let ([known (datum-get (-> state layouts) (cdr t))])
     (when (!= known 0) (return known))
     (let* ([v (type-value (syntax-local-value (name-identifier (cadr t))))] [items (syntax->list (caddr v))]
-           [saved type-arguments] [l datum 0])
-      (datum-put! (-> state layouts) (cdr t) 'laying-out)
-      (set! type-arguments (for/list ([p (parameters-of v)] [a (if (pair? (cdddr t)) (cadddr t) nil)]) (cons p a)))
-      (set! l (try (if (== (cadddr v) 'variant)
-                       (variant-layout items)
-                       (let ([r (lay-out items (== (cadddr v) 'union))])
-                         `(,(fixnum (round-up (fixnum-value (car r)) (fixnum-value (cadr r)))) ,(cadr r) ,(caddr r))))
-                   [catch-all (set! type-arguments saved) (rethrow)]))
-      (set! type-arguments saved)
+           [l (begin
+                (datum-put! (-> state layouts) (cdr t) 'laying-out)
+                (if (memq (cadddr v) '(variant enum))
+                    (variant-layout items)
+                    (let ([r (lay-out items (== (cadddr v) 'union))])
+                      `(,(fixnum (round-up (fixnum-value (car r)) (fixnum-value (cadr r)))) ,(cadr r) ,(caddr r)))))])
       (datum-put! (-> state layouts) (cdr t) l)
       l)))
 
@@ -437,8 +402,6 @@
 
 (define (substrate-define [s datum]) -> datum
   (syntax-match s
-    [(_ #:forall ((? identifier? p) ...) ((? identifier? f) ((? identifier? x) t) ...) rest ...)
-     (let ([r (result-and-body rest)]) (generic s p f x t (car r) (cdr r)))]
     [(_ ((? identifier? f) ((? identifier? x) t) ...) (? placement? k) rest ...)
      (let ([r (result-and-body rest)]) (function s f x t (car r) (cdr r) f k))]
     [(_ ((? identifier? f) ((? identifier? x) t) ...) rest ...)
@@ -465,11 +428,6 @@
                                ,(at s (syn `(#%checked body ,definer (,@xs) ,(if (!= to 0) to '#f) (quote ,(cons rt ps)) ,@body))))))
             (#%fact ,f (quote (substrate-function ,ps ,rt)))))))
 
-(define (generic [s datum] [ps datum] [f datum] [xs datum] [ts datum] [r datum] [body datum]) -> datum
-  (parse-types-with (type-variables (for/list ([p ps]) (syntax-e p))) (cons r ts))
-  (syn `(define-syntax ,f
-          (quote-syntax (#%form mark (#%substrate-generic (,f (,@ps) (,@(for/list ([x xs] [t ts]) `(,x ,t))) ,r (,@body) ,s)))))))
-
 (define (global-definition [s datum] [x datum] [t datum] [init datum]) -> datum
   (let ([ty (kept! (complete! (parse-type t) t) t)])
     (syn `(begin
@@ -538,12 +496,11 @@
 
 (define (aggregate-type [s datum] [kind datum]) -> datum
   (syntax-match s
-    [(_ #:forall ((? identifier? p) ...) (? identifier? name) field ...) (aggregate name field kind p)]
-    [(_ (? identifier? name) field ...) (aggregate name field kind nil)]))
+    [(_ (? identifier? name) field ...) (aggregate name field kind)]))
 
-(define (aggregate [name datum] [fields datum] [kind datum] [ps datum]) -> datum
+(define (aggregate [name datum] [fields datum] [kind datum]) -> datum
   (distinct! (for/list ([f fields]) (syntax-match f [((? identifier? g) _) g] [_ (substrate-error f "expected [field type]" nil)])) '"field")
-  (syn `(begin (define-syntax ,name (quote-syntax (substrate-struct ,name (,@fields) ,kind (,@ps))))
+  (syn `(begin (define-syntax ,name (quote-syntax (substrate-struct ,name (,@fields) ,kind)))
                ,(second-pass (syn `(substrate-struct-check ,name))))))
 
 (define (distinct! [ids datum] [what datum])
@@ -554,10 +511,9 @@
 
 (define (substrate-variant [s datum]) -> datum
   (syntax-match s
-    [(_ #:forall ((? identifier? p) ...) (? identifier? name) c ...) (variant-form name c p)]
-    [(_ (? identifier? name) c ...) (variant-form name c nil)]))
+    [(_ (? identifier? name) c ...) (variant-form name c)]))
 
-(define (variant-form [name datum] [cs datum] [ps datum]) -> datum
+(define (variant-form [name datum] [cs datum]) -> datum
   (let ([cases (for/list ([c cs])
                  (syntax-match c
                    [((? identifier? n) f ...)
@@ -567,7 +523,7 @@
                    [(? identifier? n) `(,n)]
                    [_ (substrate-error c "expected [case [field type] ...]" nil)]))])
     (distinct! (for/list ([c cases]) (car c)) '"case")
-    (syn `(begin (define-syntax ,name (quote-syntax (substrate-struct ,name (,@(for/list ([c cases]) `(,@c))) variant (,@ps))))
+    (syn `(begin (define-syntax ,name (quote-syntax (substrate-struct ,name (,@(for/list ([c cases]) `(,@c))) variant)))
                  ,@(for/list ([c cases] [i (numbers-below (length cases))])
                      `(define-syntax ,(car c) (quote-syntax (#%form mark (#%substrate-construct ,name ,i ,(car c))))))
                  ,(second-pass (syn `(substrate-struct-check ,name)))))))
@@ -575,7 +531,7 @@
 (define (substrate-struct-check [s datum]) -> datum
   (syntax-match s
     [(_ name)
-     (when (null? (parameters-of (type-binding name))) (layout (named-type name)))
+     (layout (named-type name))
      (syn '(begin))]))
 
 (define (substrate-exception [s datum]) -> datum
@@ -768,9 +724,6 @@
       [('offsetof)
        (unless (and (== n 3) (identifier? (caddr l))) (substrate-error s "expected (offsetof type field)" nil))
        (use `(,(piece 'type 0 (cadr l)) ,(piece 'name 0 (caddr l))))]
-      [('inst)
-       (unless (and (>= n 2) (identifier? (cadr l))) (substrate-error s "expected (inst generic type ...)" nil))
-       (use (cons (piece 'name 0 (cadr l)) (for/list ([t (cddr l)]) (piece 'type 0 t))))]
       [('throw)
        (unless (and (>= n 2) (identifier? (cadr l))) (substrate-error s "expected (throw exception value ...)" nil))
        (use (cons (piece 'name 0 (cadr l)) (exprs-in 0 (cddr l))))]
@@ -791,6 +744,12 @@
       [('lambda) (lambda-shape s)]
       [('match) (match-shape s)]
       [('try) (try-shape s)]
+      [('new)
+       (unless (or (== n 3) (== n 4)) (substrate-error s "expected (new arena type), (new arena type count) or (new arena value)" nil))
+       (use `(,(cadr l) ,(if (or (== n 4) (type-syntax? (caddr l))) (piece 'type 0 (caddr l)) (caddr l)) ,@(cdddr l)))]
+      [('copy)
+       (unless (== n 3) (substrate-error s "expected (copy arena items)" nil))
+       (use (exprs-in 0 (cdr l)))]
       [else 0])))
 
 ;; A binding is [x type value], [x value], [(x ...) value] or [(x ...) (type ...) value], or [x type]
@@ -1305,27 +1264,20 @@
            (let* ([t (piece-at m 1)] [ty (parse-type t)])
              (unless (struct-type? ty) (substrate-error t "~s is not a struct" `(,(shown ty))))
              (cons 'lit (caddr (field-of ty (piece-at m 2)))))]
-          [('inst) (check-inst s m)]
           [('#%datum) (literal s (syntax-e (piece-at m 1)))]
-          [else (check-marked s fenv (mark-arguments m) env hint)]))))
+          [('new) (check-new m env)]
+          [('copy) (check-copy m env)]
+          [else (check-marked s fenv (mark-arguments m) env)]))))
 
 (define (mark-arguments [m datum]) -> datum (if (== (car m) 'group) (pieces-from m 1) nil))
 
-(define (check-marked [s datum] [fenv datum] [args datum] [env datum] [hint datum]) -> datum
+(define (check-marked [s datum] [fenv datum] [args datum] [env datum]) -> datum
   (syntax-match fenv
-    [('#%substrate-generic g)
-     (if (pair? (syntax-e s))
-         (check-generic-call s g args env hint)
-         (syntax-match g [(f . _) (substrate-error s "~a is generic: give its types, (inst ~a type ...)" `(,(syntax-e f) ,(syntax-e f)))]))]
     [('#%substrate-construct v i n)
-     (let ([t (construct-type s v i args env hint)]) (cons t (construct s t i n args env (temp t))))]))
-
-(define (check-inst [s datum] [m datum]) -> datum
-  (let* ([f (piece-at m 1)] [h (expand-head f)])
-    (syntax-match (if (== (car h) 'form) (caddr h) 0)
-      [('#%substrate-generic g)
-       (let ([i (instance g (for/list ([u (pieces-from m 2)]) (parse-type u)) s)]) (cons (cons 'fn (function-type i)) (function-ref i)))]
-      [_ (substrate-error f "~a is not a generic function" `(,(syntax->datum f)))])))
+     (let ([t (named-type v)])
+       (if (enum-type? t)
+           (begin (case-fields s t (syntax-e i) n args) (cons t (enum-constant t (syntax-e i))))
+           (cons t (construct s t i n args env (temp t)))))]))
 
 (define (check-core [name datum] [e datum] [env datum] [hint datum]) -> datum
   (let ([m (if (== name 'let*) 0 (core-shape name e))])
@@ -1335,7 +1287,7 @@
       [('#%app)
        (let* ([f (piece-at m 1)] [fm (if (identifier? f) (meaning-of f) 0)])
          (if (literal-head? f fm)
-             (check-literal e f (cddr (syntax->list e)) env hint)
+             (check-literal e f (cddr (syntax->list e)) env)
              (check-call e f (callee f fm env) (pieces-from m 2) env)))]
       [('quote) (cons (datum-type) `(quote ,(syntax->datum (piece-at m 1))))]
       [('quote-syntax) (cons (datum-type) `(quote ,(syntax-local-introduce (prune-local-scopes (piece-at m 1)))))]
@@ -1544,6 +1496,7 @@
 (define (let-value [zero bool] [r datum] [t datum] [x datum] [init datum] [stored bool]) -> datum
   (cond [(not zero) (convert r t init stored)]
         [(view-type? t) (const-code 'i64 (fixnum 0))]
+        [(enum-type? t) (i32-const 0)]
         [else (constant (fixnum 0) t x)]))
 
 (define (let-put [r datum] [dst datum] [t datum] [init datum] [env datum]) -> datum
@@ -1695,89 +1648,10 @@
       (case (car p)
         [('call) (cadr (cadddr p))]
         [('array) (array-of-type (cadr p) (caddr p))]
-        [else (if (null? (parameters-of (type-binding (cadr p)))) (named-type (cadr p)) 0)])))
+        [else (let ([t (named-type (cadr p))]) (if (enum-type? t) 0 t))])))
 
 (define (temp [t datum]) -> datum (address (frame-place t (frame-slot! t)) 0))
 
-;; ---- generics ----
-
-(define (check-generic-call [e datum] [g datum] [args datum] [env datum] [hint datum]) -> datum
-  (syntax-match g
-    [(f (p ...) ((x a) ...) r _ _)
-     (let* ([ps (for/list ([q p]) (syntax-e q))]
-            [s (begin (set! twice (+ twice 1)) (infer e (parse-types-with (type-variables ps) a) args env))]
-            [i (instance g (for/list ([q ps]) (bound-type e s q (syntax-e f))) e)]
-            [r (check-call e i `(,(function-type i) #f direct ,(info-of i 'func "a function")) args env)])
-       (set! twice (- twice 1))
-       r)]))
-
-(define (infer [e datum] [ts datum] [args datum] [env datum]) -> datum
-  (unless (== (length ts) (length args))
-    (substrate-error e "expected ~a argument~a, got ~a" `(,(fixnum (length ts)) ,(plural (length ts)) ,(fixnum (length args)))))
-  (infer-from ts args env (infer-from ts args env nil #f) #t))
-
-(define (infer-from [ts datum] [args datum] [env datum] [s datum] [constants bool]) -> datum
-  (cond [(null? ts) s]
-        [(known-type? (car ts) s) (infer-from (cdr ts) (cdr args) env s constants)]
-        [else
-         (let ([r (check (car args) env 0)])
-           (infer-from (cdr ts) (cdr args) env
-                       (if (and (not constants) (literal-type? (car r)))
-                           s
-                           (let ([u (unify (car ts) (settled-type (car r)) s)])
-                             (if (!= u 0)
-                                 u
-                                 (substrate-error (car args) "expected ~s, got ~s" (shown-apart (applied (car ts) s) (car r))))))
-                       constants))]))
-
-(define (known-type? [t datum] [s datum]) -> bool
-  (cond [(and (pair? t) (== (car t) 'tvar)) (!= (assq (cadr t) s) 0)]
-        [(pair? t) (andmap (lambda ([u datum]) -> bool (known-type? u s)) t)]
-        [else #t]))
-
-(define (applied [t datum] [s datum]) -> datum
-  (cond [(and (pair? t) (== (car t) 'tvar)) (let ([b (assq (cadr t) s)]) (if (!= b 0) (cdr b) t))]
-        [(pair? t) (for/list ([u t]) (applied u s))]
-        [else t]))
-
-(define (unify [t datum] [u datum] [s datum]) -> datum
-  (cond [(and (pair? t) (== (car t) 'tvar))
-         (let ([b (assq (cadr t) s)])
-           (cond [(== b 0) (cons (cons (cadr t) u) s)]
-                 [(equal? (cdr b) u) s]
-                 [else 0]))]
-        [(and (pair? t) (pair? u) (== (length t) (length u))) (unify-each t u s)]
-        [(equal? t u) s]
-        [else 0]))
-
-(define (unify-each [t datum] [u datum] [s datum]) -> datum
-  (if (null? t) s (let ([s2 (unify (car t) (car u) s)]) (if (!= s2 0) (unify-each (cdr t) (cdr u) s2) 0))))
-
-(define (bound-type [e datum] [s datum] [p datum] [f datum]) -> datum
-  (let ([b (assq p s)])
-    (if (!= b 0) (cdr b) (substrate-error e "~a's type ~a is not known from its arguments: give it, (inst ~a type ...)" `(,f ,p ,f)))))
-
-(define (instance [g datum] [ts datum] [where datum]) -> datum
-  (syntax-match g
-    [(f (p ...) ((x a) ...) r (body ...) s)
-     (let* ([key (cons (identifier-name f) ts)] [known (datum-get (-> state instances) key)])
-       (if (!= known 0)
-           known
-           (let ([name (fresh (format "~a<~a>" `(,(syntax-e f) ,(joined (for/list ([t ts]) (format "~s" `(,(shown t))))))))]
-                 [sub (for/list ([q p] [t ts]) (cons (syntax-e q) t))])
-             (datum-put! (-> state instances) key (syntax-local-introduce name))
-             (let ([saved (body-state)])
-               (syntax-local-lift-definition
-                (at s (function s name x (for/list ([y a]) (replace y sub)) (replace r sub) (for/list ([b body]) (replace b sub)) f 0)))
-               (restore-body! saved))
-             (syntax-local-introduce name))))]))
-
-(define (replace [x datum] [sub datum]) -> datum
-  (cond [(identifier? x)
-         (let ([b (assq (syntax-e x) sub)]) (if (!= b 0) (datum->syntax x (cons 'quote (cons (cdr b) nil)) x) x))]
-        [(!= (syntax->list x) 0) (syntax-rewrap x (for/list ([y (syntax->list x)]) (replace y sub)))]
-        [else x]))
-
 ;; ---- closures ----
 
 (define (check-lambda [e datum] [m datum] [env datum]) -> datum
@@ -1881,8 +1755,8 @@
 (define (literal-head? [f datum] [fm datum]) -> bool
   (and (!= fm 0) (== (car fm) 'compile-time-value) (!= (struct-binding f) 0)))
 
-(define (check-literal [e datum] [f datum] [args datum] [env datum] [hint datum]) -> datum
-  (let* ([pairs (literal-pairs e f args)] [t (literal-type e f pairs env hint)])
+(define (check-literal [e datum] [f datum] [args datum] [env datum]) -> datum
+  (let* ([pairs (literal-pairs e f args)] [t (named-type f)])
     (cons t (construct-literal t pairs env (temp t)))))
 
 (define (literal-pairs [e datum] [f datum] [args datum]) -> datum
@@ -1901,21 +1775,6 @@
       (when (pair? missing) (substrate-error e "~a needs ~a" `(,(syntax-e f) ,(joined missing)))))
     (reverse out)))
 
-(define (literal-type [e datum] [f datum] [pairs datum] [env datum] [hint datum]) -> datum
-  (let ([v (struct-binding f)])
-    (cond [(null? (parameters-of v)) (named-type f)]
-          [(and (struct-type? hint) (== (cadr hint) (identifier-name f))) hint]
-          [else
-           (let* ([ps (parameters-of v)]
-                  [types (parse-types-with (type-variables ps) (for/list ([p pairs]) (declared-type v (car p))))]
-                  [s (infer e types (for/list ([p pairs]) (cdr p)) env)])
-             `(struct ,(identifier-name f) ,(cadr v) ,(for/list ([p ps]) (bound-type e s p (syntax-e f)))))])))
-
-(define (declared-type [v datum] [name datum]) -> datum
-  (for/each ([d (syntax->list (caddr v))])
-    (syntax-match d [(g gt) (when (== (syntax-e g) name) (return gt))]))
-  0)
-
 (define (construct-literal [t datum] [pairs datum] [env datum] [dst datum]) -> datum
   (let ([d (fresh-key!)] [fields (caddr (layout t))])
     `(let ((,d i32 ,dst to))
@@ -1928,16 +1787,18 @@
                  (if (== (car n) 'group)
                      `(,(piece-at n 0) (,(cdr (pieces-of n)) ,body ,(cadr c)))
                      `(,(piece-syntax n) (#f ,body ,(cadr c))))))]
-         [p (struct-base v env)] [t (car p)] [a (fresh-key!)] [tag (fresh-key!)] [nullable (pointer-base? p)]
+         [p (match-base v env)] [t (car p)] [a (fresh-key!)] [tag (fresh-key!)] [nullable (pointer-base? p)]
          [pairs (for/list ([x cs]) (cons (car x) (cadr x)))]
          [nulls (for/list ([nc pairs] #:when (null-clause? (car nc))) nc)]
          [cases (for/list ([nc pairs] #:when (not (null-clause? (car nc)))) nc)])
-    (unless (variant-type? t) (substrate-error v "match takes a variant, or a pointer to one, not ~s" `(,(shown t))))
+    (unless (or (variant-type? t) (enum-type? t)) (substrate-error v "match takes a variant, or a pointer to one, not ~s" `(,(shown t))))
     (when (and (pair? nulls) (not nullable))
       (substrate-error (car (car nulls)) "this match takes a variant, not a pointer to one, which is never 0" nil))
     (when (and (pair? nulls) (pair? (cdr nulls))) (substrate-error (car (cadr nulls)) "0 is matched twice" nil))
-    (match-arms e p t a tag nullable nulls (for/list ([c cases]) (car c)) (for/list ([c cases]) (cdr c)) nil
-                (numbers-below (length (cases-of t))) env hint)))
+    (if (enum-type? t)
+        (enum-match e p t a tag nulls cases env hint)
+        (match-arms e p t a tag nullable nulls (for/list ([c cases]) (car c)) (for/list ([c cases]) (cdr c)) nil
+                    (numbers-below (length (cases-of t))) env hint))))
 
 (define (match-arms [e datum] [p datum] [t datum] [a datum] [tag datum] [nullable bool] [nulls datum] [names datum]
                     [clauses datum] [arms datum] [left datum] [env datum] [hint datum]) -> datum
@@ -1994,18 +1855,6 @@
                                   hint)
                   hint c)))))
 
-(define (construct-type [e datum] [v datum] [i datum] [args datum] [env datum] [hint datum]) -> datum
-  (let ([b (type-binding v)])
-    (cond [(null? (parameters-of b)) (named-type v)]
-          [(and (struct-type? hint) (== (cadr hint) (identifier-name v))) hint]
-          [else
-           (let* ([ps (parameters-of b)]
-                  [fields (parse-types-with (type-variables ps)
-                                            (for/list ([f (cdr (syntax->list (list-ref (syntax->list (caddr b)) (fixnum-value (syntax-e i)))))])
-                                              (syntax-match f [(_ ft) ft])))]
-                  [s (infer e fields args env)])
-             `(struct ,(identifier-name v) ,(cadr b) ,(for/list ([p ps]) (bound-type e s p (syntax-e v)))))])))
-
 (define (case-index [n datum] [t datum]) -> datum
   (syntax-match (let ([h (expand-head n)]) (if (== (car h) 'form) (caddr h) 0))
     [('#%substrate-construct v i _)
@@ -2334,7 +2183,7 @@
                  [(float-type? t) (prim-code (op-name t 'convert_i32_u) `(,c))]
                  [else (substrate-error where "expected ~s, got bool" `(,(shown t)))])]
           [(or (struct-type? t) (struct-type? from) (closure-type? t) (closure-type? from) (values-type? t) (values-type? from)
-               (view-type? t) (view-type? from))
+               (view-type? t) (view-type? from) (enum-type? t) (enum-type? from))
            (unless (equal? from t) (substrate-error where "expected ~s, got ~s" (shown-apart t from)))
            c]
           [(address-type? t)
@@ -2390,6 +2239,13 @@
                   (cons to (cdr r))]
                  [else (substrate-error x "cannot cast ~s to ~s" `(,(shown from) ,(shown to)))])]
           [(view-type? from) (substrate-error x "cannot cast ~s to ~s" `(,(shown from) ,(shown to)))]
+          [(enum-type? to)
+           (cond [(equal? from to) (cons to (cdr r))]
+                 [(integer-type? (as-number from)) (cons to (convert r 'i32 x #f))]
+                 [else (substrate-error x "cannot cast ~s to ~s" `(,(shown from) ,(shown to)))])]
+          [(enum-type? from)
+           (unless (integer-type? to) (substrate-error x "cannot cast ~s to ~s" `(,(shown from) ,(shown to))))
+           (cons (promoted to) (numeric (cdr r) 'i32 to #t))]
           [(address-type? to)
            (cond [(== from 'lit) (cons to (const-code 'i32 (cdr r)))]
                  [(or (address-type? from) (memq from '(i32 u32))) (cons to (cdr r))]
@@ -2438,6 +2294,9 @@
            (let ([t (cond [(address-type? ta) ta]
                           [(address-type? tb) tb]
                           [(and (arithmetic? ta) (arithmetic? tb)) (common ta tb)]
+                          [(and (enum-type? ta) (equal? ta tb)) ta]
+                          [(or (enum-type? ta) (enum-type? tb))
+                           (substrate-error e "~a compares two values of the same enum, not ~s and ~s" `(,o ,(shown ta) ,(shown tb)))]
                           [else (substrate-error e "~a compares numbers, pointers or strings, not ~s and ~s" `(,o ,(shown ta) ,(shown tb)))])])
              (cons 'bool (prim-code (instruction o t) `(,(convert a t e #f) ,(convert b t e #f)))))]
           [(and (arithmetic? ta) (arithmetic? tb))
@@ -2709,6 +2568,7 @@
           [(== t 'f32) (call-of 'print-float `(,(prim-code 'f64.promote_f32 `(,(cdr r))) ,(i32-const 1)))]
           [(equal? t (datum-type)) `(call ,(syntax-function-of 'print-datum (-> state phase)) (,(cdr r) ,(i32-const display)))]
           [(address-type? t) (call-of 'print-integer `(,(prim-code 'i64.extend_i32_u `(,(cdr r))) ,(i32-const 0)))]
+          [(enum-type? t) (printed-enum r t)]
           [(and (struct-type? t) (variant-type? t)) (printed-variant r t a display)]
           [(and (struct-type? t) (== (type-kind t) 'struct)) (printed-struct r t a display)]
           [else (seq `(,(as-void r) ,(text-printed (format "#<~s>" `(,(shown t))))))])))
@@ -2779,13 +2639,10 @@
 
 (define (src [d datum]) -> datum (datum->syntax here d 0))
 
-(define (data-form [kind datum] [s datum]) -> datum
-  (case kind
-    [('make-cell)
-     (syntax-match s
-       [(_ c) (at s (src `(let ([p (cell-bytes ,(cell-size c))]) (set! (@ p) ,c) p)))]
-       [(_ a c) (at s (src `(let ([p (cast datum (arena-alloc ,a ,(cell-size c)))]) (set! (@ p) ,c) p)))])]
-    [else (syntax-match s [(_ a t) (at s (src `(cast (ptr ,t) (arena-alloc ,a (sizeof ,t)))))])]))
+(define (data-form [s datum]) -> datum
+  (syntax-match s
+    [(_ c) (at s (src `(let ([p (cell-bytes ,(cell-size c))]) (set! (@ p) ,c) p)))]
+    [(_ a c) (at s (src `(let ([p (cast datum (arena-alloc ,a ,(cell-size c)))]) (set! (@ p) ,c) p)))]))
 
 ;; A cell is a tag and its case's fields.
 (define (cell-size [c datum]) -> datum
@@ -2793,3 +2650,159 @@
       (fixnum 4)
       (let ([fields (cdr (assq (syntax-e (car (syntax->list c))) (cases-of (cadr (datum-type)))))])
         (fixnum (if (null? fields) 4 (let ([f (last fields)]) (+ (fixnum-value (caddr f)) (size-of (cadr f)))))))))
+
+(define (check-new [m datum] [env datum]) -> datum
+  (if (== (piece-role (list-ref (pieces-of m) 2)) 'type) (new-zeroed m env) (new-value m env)))
+
+(define (new-value [m datum] [env datum]) -> datum
+  (let* ([s (piece-at m 1)] [x (piece-at m 2)] [arena (expect s (arena-pointer) env #f)] [h (expand-in x env)]
+         [pr (producer-with h x)] [produced (production-type pr)]
+         [r (if (!= produced 0)
+                0
+                (let ([c (check-with h x env 0)]) (if (== (car c) 'slit) (cons 'string (string-code (cdr c))) (settle c 0 x))))]
+         [t (kept! (complete! (if (!= produced 0) produced (car r)) x) x)] [a (fresh-key!)] [p (fresh-key!)])
+    (cons `(ptr ,t)
+          `(let ((,a i32 ,arena a))
+             (let ((,p i32 ,(allocation-from s (lref a) (i32-const (size-of t))) p))
+               ,(seq `(,(cond [(!= produced 0) (as-void (constructed (lref p) pr produced x t env))]
+                              [(aggregate? t) (as-void (copied-into (lref p) r t x))]
+                              [else (store t (lref p) 0 (convert r t x #f))])
+                       ,(lref p))))))))
+
+(define (new-zeroed [m datum] [env datum]) -> datum
+  (let* ([u (piece-at m 2)] [t (kept! (complete! (parse-type u) u) u)] [size (size-of t)] [s (piece-at m 1)]
+         [arena (expect s (arena-pointer) env #f)] [a (fresh-key!)] [p (fresh-key!)])
+    (if (null? (cdddr (pieces-of m)))
+        (cons `(ptr ,t)
+              `(let ((,a i32 ,arena a))
+                 (let ((,p i32 ,(allocation-from s (lref a) (i32-const size)) p))
+                   ,(seq `(,(zero-bytes (lref p) size) ,(lref p))))))
+        (let ([n (fresh-key!)])
+          (cons `(slice ,t)
+                `(let ((,a i32 ,arena a) (,n i32 ,(expect (piece-at m 3) 'u32 env #f) n))
+                   (let ((,p i32 ,(allocation-from s (lref a) (allocation-size (lref n) size)) p))
+                     ,(seq `(,(prim-code 'memory.fill `(,(lref p) ,(i32-const 0) ,(items-size (lref n) size)))
+                             ,(view-code (lref p) (lref n)))))))))))
+
+(define (check-copy [m datum] [env datum]) -> datum
+  (let* ([s (piece-at m 1)] [arena (expect s (arena-pointer) env #f)] [x (piece-at m 2)] [c (check x env 0)]
+         [r (if (== (car c) 'slit) (cons 'string (string-code (cdr c))) (settle c 0 x))] [t (car r)])
+    (unless (view-type? t) (substrate-error x "copy takes a string or a slice, not ~s" `(,(shown t))))
+    (let ([size (size-of (complete! (view-items t) x))] [a (fresh-key!)] [v (fresh-key!)] [n (fresh-key!)] [p (fresh-key!)])
+      (cons t `(let ((,a i32 ,arena a) (,v i64 ,(cdr r) v))
+                 (let ((,n i32 ,(view-length (lref v)) n))
+                   (let ((,p i32 ,(allocation-from s (lref a) (allocation-size (lref n) size)) p))
+                     ,(seq `(,(prim-code 'memory.copy `(,(lref p) ,(view-pointer (lref v)) ,(items-size (lref n) size)))
+                             ,(view-code (lref p) (lref n)))))))))))
+
+(define (arena-pointer) -> datum `(ptr ,(named-type (datum->syntax here 'arena 0))))
+
+(define (allocation-from [s datum] [a datum] [size datum]) -> datum
+  (cond [(zero? (syntax-e s)) (call-of 'malloc `(,size))]
+        [(syntax-match s [('& _) #t] [_ #f]) (call-of 'arena-alloc `(,a ,size))]
+        [else
+         (let ([n (fresh-key!)])
+           `(let ((,n i32 ,size n))
+              (if ,(prim-code 'i32.eqz `(,a)) ,(call-of 'malloc `(,(lref n))) ,(call-of 'arena-alloc `(,a ,(lref n))))))]))
+
+(define (items-size [n datum] [size i32]) -> datum (if (== size 1) n (prim-code 'i32.mul `(,n ,(i32-const size)))))
+
+;; Past the limit, a size that malloc refuses.
+(define (allocation-size [n datum] [size i32]) -> datum
+  (if (== size 0)
+      (i32-const 0)
+      `(select ,(i32-const 2147483584) ,(items-size n size) ,(prim-code 'i32.gt_u `(,n ,(i32-const (/ 2147483584 size)))))))
+
+;; ---- enums ----
+
+(define (substrate-enum [s datum]) -> datum
+  (syntax-match s
+    [(_ (? identifier? name) c ...) (if (null? c) (substrate-error s "expected (enum name case ...)" nil) (enum-form name c))]
+    [_ (substrate-error s "expected (enum name case ...)" nil)]))
+
+(define (enum-form [name datum] [cs datum]) -> datum
+  (let* ([names (for/list ([c cs])
+                  (syntax-match c
+                    [(? identifier? n) n]
+                    [((? identifier? n) k) (unless (integer? (syntax-e k)) (substrate-error k "expected a number" nil)) n]
+                    [_ (substrate-error c "expected a case or [case number]" nil)]))]
+         [given (for/list ([c cs]) (syntax-match c [(_ k) k] [_ 0]))])
+    (distinct! names '"case")
+    (syn `(begin (define-syntax ,name (quote-syntax (substrate-struct ,name (,@(for/list ([n names]) `(,n))) enum ,(case-numbers cs given))))
+                 ,@(for/list ([n names] [i (numbers-below (length names))])
+                     `(define-syntax ,n (quote-syntax (#%form mark (#%substrate-construct ,name ,i ,n)))))))))
+
+(define (case-numbers [cs datum] [given datum]) -> datum
+  (let ([next i64 0] [out nil])
+    (while (pair? cs)
+      (let* ([k (car given)] [n (if (== k 0) next (integer-value (syntax-e k)))] [d (make-integer n)])
+        (when (or (< n -2147483648) (> n 2147483647)) (substrate-error (car cs) "a case's number is a 32-bit integer" nil))
+        (when (member d out) (substrate-error (car cs) "two cases have the number ~a" `(,d)))
+        (set! out (cons d out))
+        (set! next (+ n 1)))
+      (set! cs (cdr cs))
+      (set! given (cdr given)))
+    (reverse out)))
+
+(define (enum-numbers [t datum]) -> datum (numbers-of (type-value (syntax-local-value (name-identifier (cadr t))))))
+
+(define (enum-constant [t datum] [i datum]) -> datum (const-code 'i32 (list-ref (enum-numbers t) (fixnum-value i))))
+
+(define (match-base [s datum] [env datum]) -> datum
+  (let* ([h (expand-head s)] [p (if (place-head? h) (place-with h s env) 0)])
+    (if (and (!= p 0) (or (struct-type? (car p)) (view-type? (car p))))
+        p
+        (let ([r (if (!= p 0) (read-place p s) (check-with h s env 0))])
+          (cond [(enum-type? (car r)) `(,(car r) local ,(cdr r))]
+                [(and (pointer? (car r)) (enum-type? (cadr (car r)))) `(,(cadr (car r)) memory ,(cdr r) 0 pointer)]
+                [else (based r s)])))))
+
+(define (enum-match [e datum] [p datum] [t datum] [a datum] [k datum] [nulls datum] [clauses datum] [env datum] [hint datum])
+  -> datum
+  (let ([left (numbers-below (length (cases-of t)))] [arms nil] [default datum 0] [numbers (enum-numbers t)]
+        [null-arm (if (pair? nulls) (check-sequence (cadddr (car nulls)) (caddr (car nulls)) env hint) 0)])
+    (for/each ([c clauses])
+      (let* ([n (car c)] [x (cadr c)] [cl (cadddr c)] [i (if (== (syntax-e n) '_) 0 (case-index n t))])
+        (when (null? left) (substrate-error cl "this clause can never match" nil))
+        (when (and (!= i 0) (not (member i left))) (substrate-error n "~a is matched twice" `(,(syntax-e n))))
+        (when (pair? x) (substrate-error cl "~a has ~a field~a, not ~a" `(,(syntax-e n) ,(fixnum 0) ,(plural 0) ,(fixnum (length x)))))
+        (let ([r (check-sequence cl (caddr c) env hint)])
+          (if (== i 0)
+              (begin
+                (set! default (cons r cl))
+                (set! left nil))
+              (begin
+                (set! arms (cons `(,(list-ref numbers (fixnum-value i)) ,r ,cl) arms))
+                (set! left (for/list ([j left] #:when (not (equal? j i))) j)))))))
+    (when (and (pair? left) (== default 0))
+      (substrate-error e "this match does not cover ~a" `(,(joined (for/list ([i left]) (car (list-ref (cases-of t) (fixnum-value i))))))))
+    (let* ([arms (reverse arms)]
+           [j (for/fold ([ty (if (!= default 0) (car (car default)) (if (!= null-arm 0) (car null-arm) 'none))]) ([x arms])
+                (join ty (car (cadr x))))]
+           [j (if (!= null-arm 0) (join j (car null-arm)) j)]
+           [ty (if (and (== j 'void) (!= hint 0) (!= hint 'void)) hint (promoted (settled-for j hint)))]
+           [chain `(let ((,k i32 ,(if (== (cadr p) 'local) (caddr p) (load t (lref a) (fixnum-value (cadddr p)))) tag))
+                     ,(enum-chain arms default ty k))])
+      (cons ty (cond [(== (cadr p) 'local) chain]
+                     [(!= null-arm 0)
+                      `(let ((,a i32 ,(caddr p) a))
+                         (if ,(prim-code 'i32.eqz `(,(lref a))) ,(as null-arm ty (cadddr (car nulls))) ,chain))]
+                     [else `(let ((,a i32 ,(caddr p) a)) ,chain)])))))
+
+(define (enum-chain [arms datum] [default datum] [ty datum] [k datum]) -> datum
+  (if (null? arms)
+      (if (!= default 0) (as (car default) ty (cdr default)) '(unreachable))
+      `(if ,(prim-code 'i32.eq `(,(lref k) ,(const-code 'i32 (car (car arms)))))
+           ,(as (cadr (car arms)) ty (caddr (car arms)))
+           ,(enum-chain (cdr arms) default ty k))))
+
+(define (printed-enum [r datum] [t datum]) -> datum
+  (let ([k (fresh-key!)])
+    `(let ((,k i32 ,(cdr r) k)) ,(enum-printed k (for/list ([c (cases-of t)]) (car c)) (enum-numbers t)))))
+
+(define (enum-printed [k datum] [names datum] [numbers datum]) -> datum
+  (if (null? names)
+      (call-of 'print-integer `(,(prim-code 'i64.extend_i32_s `(,(lref k))) ,(i32-const 1)))
+      `(if ,(prim-code 'i32.eq `(,(lref k) ,(const-code 'i32 (car numbers))))
+           ,(text-printed (format "~a" `(,(car names))))
+           ,(enum-printed k (cdr names) (cdr numbers)))))