substrate-lang 0.9.3 → 0.9.4

package/std/test/test.sub

@@ -2,6 +2,9 @@
 ;; program, with the grants that substrate test gives every test plus those in its #:grants; #:grants can ask only for
 ;; what substrate test itself was given. A test ends once nothing it started is still pending, and #:output and
 ;; #:output-file check everything it printed.
+;;
+;; In #:grants, (toolchain) lets a test run the toolchain, as the helpers in run.sub do. That amounts to every grant,
+;; because the toolchain can be started with any grants.
 (require-unqualified host/fs)
 (require-unqualified host/events)
 (require-unqualified host/modules/clock)
@@ -11,20 +14,16 @@
 (require-unqualified host/node/env)
 (require-unqualified "compare.sub")
 
-(provide run-tests expect-output expect-output-file test-path scratch-directory
+(provide run-tests expect-output expect-output-file test-path scratch-directory toolchain-host
          compare-output! compare-output-file!)
 
 ;; ---- the runner ----
 
 (struct entry [module string] [name string] [line u32] [skip string] [traps string]
               [grants (slice (slice string))] [output string] [output-file string] [run (fn ())]
-              [outcome u32] [why string] [report buffer])
+              [outcome outcome] [why string] [report buffer])
 
-(const waiting u32 0)
-(const unrun u32 1)
-(const passing u32 2)
-(const failing u32 3)
-(const skipping u32 4)
+(enum outcome waiting unrun passing failing skipping)
 
 (define entries (ptr entry) 0)
 (define entry-count u32 0)
@@ -53,12 +52,9 @@
 ;; Copies the clauses to the heap, since most tests start after main has returned.
 (define (kept-clauses [clauses (slice (slice string))]) -> (slice (slice string))
   (when (== (-> clauses length) 0) (return clauses))
-  (let ([out (cast (ptr (slice string)) (malloc (* (-> clauses length) (sizeof (slice string)))))])
-    (for ([i u32 0]) (< i (-> clauses length)) (+= i 1)
-      (let* ([c (@ clauses i)] [items (cast (ptr string) (malloc (* (-> c length) (sizeof string))))])
-        (for ([j u32 0]) (< j (-> c length)) (+= j 1) (set! (@ items j) (@ c j)))
-        (set! (@ out i) (slice items (-> c length)))))
-    (slice out (-> clauses length))))
+  (let ([out (new 0 (slice string) (-> clauses length))])
+    (for ([i u32 0]) (< i (-> clauses length)) (+= i 1) (set! (@ out i) (copy 0 (@ clauses i))))
+    out))
 
 (define system string "")
 
@@ -129,6 +125,13 @@
 ;; The test's own scratch directory, which is empty when the test starts.
 (define (scratch-directory) -> string (setting "SUBSTRATE_SCRATCH"))
 
+;; The toolchain's host, which (toolchain) in #:grants lets a test run.
+(define (toolchain-host) -> string
+  (let ([b (make-buffer)])
+    (buffer-add-string! (& b) (setting "SUBSTRATE_TOOLCHAIN"))
+    (buffer-add-string! (& b) "/host/subhost.mjs")
+    (buffer-string (& b))))
+
 (define (selected? [e (ptr entry)]) -> bool
   (let ([any #f] [i u32 0])
     (while (< i (-> arguments length))
@@ -164,7 +167,7 @@
   (set! run-scratch (setting "SUBSTRATE_SCRATCH"))
   (set! started (clock-monotonic))
   (let ([n (if capturing at-once 1)])
-    (set! slots (cast (ptr slot) (calloc n (sizeof slot))))
+    (set! slots (-> (new 0 slot n) items))
     (for ([i u32 0]) (< i n) (+= i 1) (slot-go! (& (@ slots i)))))
   (reported!))
 
@@ -216,9 +219,13 @@
     (grants-allow! (& (-> o grants)) grant-read scratch)
     (grants-allow! (& (-> o grants)) grant-write scratch)
     (for ([i u32 0]) (< i (-> e grants length)) (+= i 1)
-      (let ([c (@ (-> e grants) i)] [items (make-buffer)])
-        (for ([j u32 1]) (< j (-> c length)) (+= j 1) (pushed! (& items) (scratch-placed (@ c j) scratch)))
-        (unless (grants-add! (& (-> o grants)) (@ c 0) (strings-in (& items)) (& why))
+      (let ([c (@ (-> e grants) i)] [items (make-buffer)] [kind (@ (@ (-> e grants) i) 0)])
+        (if (and (== kind "toolchain") (== (-> c length) 1))
+            (begin
+              (set! kind "run")
+              (pushed! (& items) (toolchain-host)))
+            (for ([j u32 1]) (< j (-> c length)) (+= j 1) (pushed! (& items) (scratch-placed (@ c j) scratch))))
+        (unless (grants-add! (& (-> o grants)) kind (strings-in (& items)) (& why))
           (failed! e why "")
           (return #f))))
     (set! (-> s entry) e)

package/substrate/VERSION

@@ -1 +1 @@
-0.9.3
+0.9.4

package/substrate/compiler/binary.sub

@@ -70,7 +70,7 @@
         [current (ptr srcloc)] [start (ptr srcloc)] [started bool] [else-pending bool])
 
 (define (new-asm) -> (ptr asm)
-  (let ([a (cast (ptr asm) (arena-alloc (current-arena) (sizeof asm)))])
+  (let ([a (new (current-arena) asm)])
     (set! (-> a out) (make-buffer))
     (set! (-> a relocs) 0)
     (set! (-> a locations) 0)
@@ -86,7 +86,7 @@
 (struct cell-record [self datum] [value datum])
 
 (define (cell [v datum]) -> datum
-  (let ([c (cast (ptr cell-record) (arena-alloc (current-arena) (sizeof cell-record)))])
+  (let ([c (new (current-arena) cell-record)])
     (set! (-> c self) (make-record-in (current-arena) cell-kind c))
     (set! (-> c value) v)
     (-> c self)))
@@ -96,23 +96,14 @@
 (define (set-cell-value! [c datum] [v datum]) (set! (-> (cast (ptr cell-record) (record-pointer c)) value) v))
 
 (define (reloc! [a (ptr asm)] [kind datum] [key datum])
-  (let ([r (cast (ptr reloc) (arena-alloc (current-arena) (sizeof reloc)))])
-    (set! (-> r offset) (asm-size a))
-    (set! (-> r kind) kind)
-    (set! (-> r key) key)
-    (set! (-> r next) (-> a relocs))
-    (set! (-> a relocs) r)))
+  (set! (-> a relocs) (new (current-arena) (reloc #:offset (asm-size a) #:kind kind #:key key #:next (-> a relocs)))))
 
 ;; ---- source locations ----
 
 (define code-locations (ptr code-location) 0)
 
 (define (new-location [offset u32] [loc (ptr srcloc)] [next (ptr code-location)]) -> (ptr code-location)
-  (let ([l (cast (ptr code-location) (arena-alloc (current-arena) (sizeof code-location)))])
-    (set! (-> l offset) offset)
-    (set! (-> l loc) loc)
-    (set! (-> l next) next)
-    l))
+  (new (current-arena) (code-location #:offset offset #:loc loc #:next next)))
 
 (define (same-location? [a (ptr srcloc)] [b (ptr srcloc)]) -> bool
   (or (== a b)
@@ -283,7 +274,7 @@
 
 (define (link-body [a (ptr asm)] [b (ptr asm)] [resolve (closure (datum datum) -> datum)]) -> datum
   (let ([q (make-buffer)] [notes (ptr code-location) 0]
-        [l (cast (ptr linked) (arena-alloc (current-arena) (sizeof linked)))])
+        [l (new (current-arena) linked)])
     (set! notes (link-segment! (& q) a resolve notes))
     (when (!= b 0)
       (when (-> b started) (set! notes (new-location (-> q length) (-> b start) notes)))

package/substrate/compiler/checker.sub

@@ -111,7 +111,7 @@
   (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))
@@ -138,6 +138,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 +146,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 +170,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 +224,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.
@@ -255,6 +257,7 @@
         [(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))]
+        [(enum-type? t) (if full (cadr t) (caddr t))]
         [(and (pair? t) (== (car t) 'tvar)) (cadr t)]
         [(values-type? t) (cons 'values (for/list ([u (cdr t)]) (shown-as u full)))]
         [(== t 'none) 'void]
@@ -312,6 +315,7 @@
     `(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) 5) (list-ref v 5) 0))
 
 ;; A type's compile-time value: (substrate-struct name (field ...) kind (parameter ...)) or
 ;; (substrate-typedef type).
@@ -325,6 +329,8 @@
         (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 (p ...) (x ...))
+                     `(substrate-struct ,(syntax-e n) ,fs ,(syntax-e k) ,(for/list ([q p]) (syntax-e q)) ,(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)))
@@ -335,6 +341,7 @@
     (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
@@ -349,7 +356,7 @@
     [_ #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) (and (pair? t) (== (car t) 'tvar)))
     (substrate-error where "expected a number or pointer type, not ~s" `(,(shown t))))
   t)
 
@@ -397,7 +404,7 @@
            [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)
+      (set! l (try (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))))
@@ -791,6 +798,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]
@@ -1307,6 +1320,8 @@
              (cons 'lit (caddr (field-of ty (piece-at m 2)))))]
           [('inst) (check-inst s m)]
           [('#%datum) (literal s (syntax-e (piece-at m 1)))]
+          [('new) (check-new m env)]
+          [('copy) (check-copy m env)]
           [else (check-marked s fenv (mark-arguments m) env hint)]))))
 
 (define (mark-arguments [m datum]) -> datum (if (== (car m) 'group) (pieces-from m 1) nil))
@@ -1318,7 +1333,10 @@
          (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))))]))
+     (let ([t (construct-type s v i args env hint)])
+       (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-inst [s datum] [m datum]) -> datum
   (let* ([f (piece-at m 1)] [h (expand-head f)])
@@ -1544,6 +1562,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,7 +1714,7 @@
       (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 (if (null? (parameters-of (type-binding (cadr p)))) (let ([t (named-type (cadr p))]) (if (enum-type? t) 0 t)) 0)])))
 
 (define (temp [t datum]) -> datum (address (frame-place t (frame-slot! t)) 0))
 
@@ -1928,16 +1947,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
@@ -2334,7 +2355,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 +2411,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 +2466,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 +2740,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 +2811,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 +2822,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)))))

package/substrate/compiler/compile.sub

@@ -111,7 +111,7 @@
 ;; ---- per-function state ----
 
 (define (new-fctx [params datum] [results datum]) -> (ptr fctx)
-  (let ([fc (cast (ptr fctx) (arena-alloc (current-arena) (sizeof fctx)))])
+  (let ([fc (new (current-arena) fctx)])
     (set! (-> fc locals) (make-table))
     (set! (-> fc extra) nil)
     (set! (-> fc next) 0)
@@ -147,7 +147,7 @@
 (define compiling datum 0)
 
 (define (push-label [key datum] [kind datum] [type datum] [next (ptr label)]) -> (ptr label)
-  (let ([l (cast (ptr label) (arena-alloc (current-arena) (sizeof label)))])
+  (let ([l (new (current-arena) label)])
     (set! (-> l key) key)
     (set! (-> l kind) kind)
     (set! (-> l type) type)
@@ -177,7 +177,7 @@
 (define (synth-of [d datum]) -> (ptr synth) (cast (ptr synth) (record-pointer d)))
 
 (define (new-mstate [self datum]) -> (ptr mstate)
-  (let ([ms (cast (ptr mstate) (arena-alloc (current-arena) (sizeof mstate)))])
+  (let ([ms (new (current-arena) mstate)])
     (set! (-> ms self) self)
     (set! (-> ms func-imports) nil)
     (set! (-> ms global-imports) nil)
@@ -240,7 +240,7 @@
     (set! (-> ms table-loc) current-loc)))
 
 (define (new-synth! [ms (ptr mstate)] [kind datum] [info datum]) -> datum
-  (let ([s (cast (ptr synth) (arena-alloc (current-arena) (sizeof synth)))])
+  (let ([s (new (current-arena) synth)])
     (set! (-> s self) (make-record-in (current-arena) synth-kind s))
     (set! (-> s kind) kind)
     (set! (-> s info) info)
@@ -626,7 +626,7 @@
 
 (define (compile-function [ms (ptr mstate)] [info datum] [params datum] [body datum]) -> (ptr compiled)
   (let ([fc (new-fctx params (func-info-results info))]
-        [cf (cast (ptr compiled) (arena-alloc (current-arena) (sizeof compiled)))])
+        [cf (new (current-arena) compiled)])
     (set! (-> ms fname) (func-info-name info))
     (set! compiling (func-info-name info))
     (set! current-loc 0)
@@ -757,7 +757,7 @@
                 (set-tag-info-export! (cadr f) (export-name! ms (tag-info-name (cadr f)))))
               tag-forms)
     (set! constants (constant-inits ms global-forms))
-    (set! last (cast (ptr compiled) (arena-alloc (current-arena) (sizeof compiled))))
+    (set! last (new (current-arena) compiled))
     (set! (-> last next) 0)
     (set! first last)
     (for-each (lambda ([f datum])
@@ -814,7 +814,7 @@
 (define (table-functions! [ms (ptr mstate)] [last (ptr compiled)] [segment i64]) -> (ptr compiled)
   (let ([ts (reverse (-> ms tables))])
     (while (pair? ts)
-      (let ([t (car ts)] [a (new-asm)] [cf (cast (ptr compiled) (arena-alloc (current-arena) (sizeof compiled)))])
+      (let ([t (car ts)] [a (new-asm)] [cf (new (current-arena) compiled)])
         (instr! a `(i32.const ,(caddr t)))
         (instr! a `(call ,(list-ref t 4)))
         (instr! a `(global.set ,(car t)))
@@ -973,7 +973,7 @@
 (define (link-module [ms (ptr mstate)] [compiled (ptr compiled)] [start-fc (ptr fctx)] [setup (ptr asm)]
                      [literal-segment datum] [global-forms datum] [tag-forms datum] [memory-form datum]
                      [table-form datum] [constants (ptr hash-table)]) -> datum
-  (let* ([lk (cast (ptr linker) (arena-alloc (current-arena) (sizeof linker)))]
+  (let* ([lk (new (current-arena) linker)]
          [has-start (or (> (asm-size setup) 0) (> (asm-size (-> start-fc asm)) 0))]
          [func-imports (reverse (-> ms func-imports))]
          [global-imports (reverse (-> ms global-imports))]