substrate-lang 0.9.3 → 0.10.0

package/std/test/compare.sub

@@ -23,8 +23,7 @@
         (begin
           (for ([i u32 0]) (< i n) (+= i 1) (diff-line! b 1 (@ xs i)))
           (for ([j u32 0]) (< j m) (+= j 1) (diff-line! b 2 (@ ys j))))
-        (let ([t (cast (ptr u32) (calloc (* (+ n 1) (+ m 1)) 4))] [w (+ m 1)]
-              [kinds (cast (ptr u8) (malloc (+ n m)))] [texts (cast (ptr string) (malloc (* (+ n m) (sizeof string))))]
+        (let ([t (new 0 u32 (* (+ n 1) (+ m 1)))] [w (+ m 1)] [kinds (new 0 u8 (+ n m))] [texts (new 0 string (+ n m))]
               [k u32 0] [i u32 0] [j u32 0] [skipped #f])
           (for ([a u32 n]) (> a 0) (-= a 1)
             (for ([c u32 m]) (> c 0) (-= c 1)
@@ -55,13 +54,13 @@
                   (set! skipped #f)
                   (diff-line! b (@ kinds p) (@ texts p)))
                 (set! skipped #t)))
-          (free (cast (ptr u8) t))
-          (free kinds)
-          (free (cast (ptr u8) texts))))
-    (free (cast (ptr u8) (-> xs items)))
-    (free (cast (ptr u8) (-> ys items)))))
+          (free (-> t items))
+          (free (-> kinds items))
+          (free (-> texts items))))
+    (free (-> xs items))
+    (free (-> ys items))))
 
-(define (changed-near? [kinds (ptr u8)] [k u32] [p u32]) -> bool
+(define (changed-near? [kinds (slice u8)] [k u32] [p u32]) -> bool
   (for ([q u32 (if (> p 2) (- p 2) 0)]) (and (< q k) (<= q (+ p 2))) (+= q 1)
     (when (!= (@ kinds q) 0) (return #t)))
   #f)
@@ -75,11 +74,11 @@
   (let ([n u32 0] [start u32 0] [k u32 0])
     (for ([i u32 0]) (< i (-> text length)) (+= i 1) (when (== (@ text i) 10) (+= n 1)))
     (when (and (> (-> text length) 0) (!= (@ text (- (-> text length) 1)) 10)) (+= n 1))
-    (let ([out (cast (ptr string) (malloc (* (+ n 1) (sizeof string))))])
+    (let ([out (new 0 string (+ n 1))])
       (for ([i u32 0]) (<= i (-> text length)) (+= i 1)
         (when (or (== i (-> text length)) (== (@ text i) 10))
           (when (or (< start i) (< i (-> text length)))
             (set! (@ out k) (slice text start i))
             (+= k 1))
           (set! start (+ i 1))))
-      (slice out k))))
+      (slice out 0 k))))

package/std/test/page.sub

@@ -62,12 +62,14 @@
 
 ;; ---- opening and closing ----
 
-(define (page-open [dir string] [url string] [address string] [server (fn ())] [err (ptr string)]) -> (ptr page)
-  (let ([b (ptr page) 0])
-    (try (set! b (opened! dir url address server))
-      [catch page-failed (why) (set! (@ err) why)])
+(define (page-open [dir string] [url string] [address string] [server (fn ())] [b (ptr (ptr page))] [err (ptr error)])
+  -> bool
+  (let ([ok #t])
+    (set! (@ b) 0)
+    (try (set! (@ b) (opened! dir url address server))
+      [catch page-failed (why) (set! ok (error-fail! err error-other why))])
     (arena-free (& work))
-    b))
+    ok))
 
 (define (page-close [b (ptr page)])
   (closed! b)
@@ -75,10 +77,10 @@
 
 (define (opened! [dir string] [url string] [address string] [server (fn ())]) -> (ptr page)
   (unless connected
-    (let ([why string])
-      (unless (devtools-connect (& connection) address heard 0 (& why)) (throw page-failed why))
+    (let ([why error])
+      (unless (devtools-connect (& connection) address heard 0 (& why)) (throw page-failed (error-text (& why))))
       (set! connected #t)))
-  (let ([b (cast (ptr page) (calloc 1 (sizeof page)))])
+  (let ([b (new 0 page)])
     (+= opened 1)
     (set! (-> b site) (kept (absolute dir)))
     (buffer-add-u32! (& pages) (cast u32 b))
@@ -134,7 +136,7 @@
     (loaded! b "Page.navigate" (params-text (& p)))))
 
 (define (closed! [b (ptr page)])
-  (let ([all (opened-pages)] [r (ptr json-value) 0] [why string] [p (params-of)])
+  (let ([all (opened-pages)] [r (ptr json-value) 0] [p (params-of)])
     (for ([i u32 0]) (< i (-> all length)) (+= i 1)
       (when (== (@ all i) (cast u32 b))
         (memcpy (cast (ptr u8) (+ (-> all items) i)) (cast (ptr u8) (+ (-> all items) (+ i 1))) (* (- (-> all length) (+ i 1)) 4))
@@ -142,7 +144,7 @@
         (break)))
     (when (and connected (> (-> b context length) 0))
       (param-string! (& p) "browserContextId" (-> b context))
-      (devtools-call (& connection) (& work) "Target.disposeBrowserContext" (params-text (& p)) "" (& r) (& why)))
+      (devtools-call (& connection) (& work) "Target.disposeBrowserContext" (params-text (& p)) "" (& r) 0))
     (when (> (-> b downloads-dir length) 0) (fs-remove (-> b downloads-dir) #t 0))
     (unless (== (-> b server) 0) (worker-stop (-> b server)))
     (when (and connected (== (-> pages length) 0))
@@ -158,12 +160,13 @@
 ;; Starts the server on a worker with the site's directory as its argument, and gives the first line it prints, its
 ;; address, with index.html after it.
 (define (served-from! [b (ptr page)] [server (fn ())]) -> string
-  (let ([o worker-options] [why string] [line (make-buffer)] [said (make-buffer)] [until (+ (clock-monotonic) 60000.0)])
+  (let ([o worker-options] [why error] [line (make-buffer)] [said (make-buffer)] [until (+ (clock-monotonic) 60000.0)])
     (worker-options-init! (& o))
     (set! (-> o output) #t)
     (set! (-> server-head handle) unheard)
-    (set! (-> b server) (worker-start server (cast (slice u8) (-> b site)) (& o) (cast (ptr void) (& server-head)) (& why)))
-    (when (== (-> b server) 0) (throw page-failed why))
+    (unless (worker-start server (cast (slice u8) (-> b site)) (& o) (cast (ptr void) (& server-head)) (& (-> b server))
+                          (& why))
+      (throw page-failed (error-text (& why))))
     (while #t
       (let ([left (- until (clock-monotonic))] [value i32 0] [bytes (slice u8)] [kind i32 0] [ended string ""])
         (when (<= left 0.0) (throw page-failed "the server did not print its address within 60 s"))
@@ -365,9 +368,9 @@
 
 (define (page-choose-files! [b (ptr page)] [paths (slice string)])
   (guarded b
-    (let ([out (make-buffer)] [info fs-info] [why string])
+    (let ([out (make-buffer)] [info fs-info] [why error])
       (for ([i u32 0]) (< i (-> paths length)) (+= i 1)
-        (when (< (fs-stat (@ paths i) (& info) (& why)) 0) (throw page-failed why))
+        (unless (fs-stat (@ paths i) (& info) (& why)) (throw page-failed (error-text (& why))))
         (pushed-text! (& out) (native-path (absolute (@ paths i)))))
       (set! (-> b chosen) (strings-in (& out)))
       (set! (-> b choosing) #t))))
@@ -563,8 +566,8 @@
   (try (evaluated b "window.ready = false") [catch page-failed (why) (begin)])
   (set! (-> b thrown) #f)
   (set! (-> b errors length) 0)
-  (let ([error (text-at (page-call b method parameters) "errorText")])
-    (when (> (-> error length) 0) (throw page-failed (cat "the browser cannot open the page: " error))))
+  (let ([refusal (text-at (page-call b method parameters) "errorText")])
+    (when (> (-> refusal length) 0) (throw page-failed (cat "the browser cannot open the page: " refusal))))
   (started! b))
 
 ;; Asks the agent in the page to carry out the request, and gives its answer.
@@ -621,10 +624,10 @@
     (while #t
       (let ([all (cast (ptr download) (-> b downloads bytes))] [n (/ (-> b downloads length) (sizeof download))])
         (for ([i u32 0]) (< i n) (+= i 1)
-          (let ([d (+ all i)] [bytes (slice u8)] [why string])
+          (let ([d (+ all i)] [bytes (slice u8)] [why error])
             (when (and (== (-> d name) name) (== (-> d state) "completed"))
-              (when (< (fs-read-file (joined-path (-> b downloads-dir) (-> d guid)) (& bytes) (& why)) 0)
-                (throw page-failed why))
+              (unless (fs-read-file (joined-path (-> b downloads-dir) (-> d guid)) (& bytes) (& why))
+                (throw page-failed (error-text (& why))))
               (return bytes)))))
       (when (>= (clock-monotonic) until) (throw page-failed (cat (cat "no file named " (quoted name)) " was downloaded")))
       (devtools-pump (& connection) 20.0))
@@ -689,7 +692,7 @@
           [(== from origin)
            (let* ([file (if (== path "/") "/index.html" path)] [bytes (slice u8)]
                   [full (resolved-path (-> b site) (slice file 1 (-> file length)))])
-             (if (and (within? full (-> b site)) (>= (fs-read-file full (& bytes) 0) 0))
+             (if (and (within? full (-> b site)) (fs-read-file full (& bytes) 0))
                  (fulfilled! session request 200 (type-of file) bytes #f)
                  (fulfilled! session request 404 "text/plain" (cast (slice u8) "not found") #f)))]
           [(and (> (-> b server-host length) 0) (== (host-of from) (-> b server-host)))
@@ -722,7 +725,7 @@
 
 ;; A file picker that opened gives the files the test chose, or else is cancelled.
 (define (chose! [b (ptr page)] [node f64])
-  (let ([q (params-of)] [a (make-arena)] [r (ptr json-value) 0] [why string])
+  (let ([q (params-of)] [a (make-arena)] [r (ptr json-value) 0] [why error])
     (param-number! (& q) "backendNodeId" node)
     (if (-> b choosing)
         (let ([files (make-buffer)])
@@ -734,21 +737,23 @@
           (buffer-add-byte! (& files) #\])
           (param-raw! (& q) "files" (buffer-string (& files)))
           (unless (devtools-call (& connection) (& a) "DOM.setFileInputFiles" (params-text (& q)) (-> b session) (& r) (& why))
-            (pushed-text! (& (-> b lines)) (cat "files: " why))))
+            (pushed-text! (& (-> b lines)) (cat "files: " (error-text (& why))))))
         (if (devtools-call (& connection) (& a) "DOM.resolveNode" (params-text (& q)) (-> b session) (& r) (& why))
             (let ([p (params-of)])
               (param-string! (& p) "objectId" (text-at (json-get r "object") "objectId"))
               (param-string! (& p) "functionDeclaration" "function () { this.dispatchEvent(new Event('cancel')); }")
               (unless (devtools-call (& connection) (& a) "Runtime.callFunctionOn" (params-text (& p)) (-> b session) (& r) (& why))
-                (pushed-text! (& (-> b lines)) (cat "files: " why))))
-            (pushed-text! (& (-> b lines)) (cat "files: " why))))
+                (pushed-text! (& (-> b lines)) (cat "files: " (error-text (& why))))))
+            (pushed-text! (& (-> b lines)) (cat "files: " (error-text (& why))))))
+    (error-free! (& why))
     (arena-free (& a))))
 
 ;; ---- helpers ----
 
 (define (call [method string] [parameters string] [session string]) -> (ptr json-value)
-  (let ([r (ptr json-value) 0] [why string])
-    (unless (devtools-call (& connection) (& work) method parameters session (& r) (& why)) (throw page-failed why))
+  (let ([r (ptr json-value) 0] [why error])
+    (unless (devtools-call (& connection) (& work) method parameters session (& r) (& why))
+      (throw page-failed (error-text (& why))))
     r))
 
 (define (page-call [b (ptr page)] [method string] [parameters string]) -> (ptr json-value)

package/std/test/run.sub

@@ -21,24 +21,25 @@
 ;; ---- running ----
 
 (define (program-in [dir string] [program string] [env (slice string)] [args (slice string)] [input (slice u8)]) -> ran
-  (let ([o process-options] [r ran] [bytes (slice u8)] [why string])
+  (let ([o process-options] [r ran] [bytes (slice u8)] [why error])
     (process-options-init! (& o))
     (set! (-> o dir) dir)
     (set! (-> o env) env)
-    (set! (-> r code) (process-run program args (& o) input 60000 (& bytes) (& why)))
-    (when (< (-> r code) 0) (throw test-failed (joined (joined program ": ") why)))
+    (unless (process-run program args (& o) input 60000 (& bytes) (& (-> r code)) (& why))
+      (throw test-failed (joined (joined program ": ") (error-text (& why)))))
     (set! (-> r output) (cast string bytes))
     r))
 
 (define (granted [clauses (slice (slice string))]) -> grants
-  (let ([g (make-grants)] [why string])
+  (let ([g (make-grants)] [why error])
     (for ([i u32 0]) (< i (-> clauses length)) (+= i 1)
       (let ([c (@ clauses i)])
-        (unless (grants-add! (& g) (@ c 0) (slice c 1 (-> c length)) (& why)) (throw test-failed why))))
+        (unless (grants-add! (& g) (@ c 0) (slice c 1 (-> c length)) (& why))
+          (throw test-failed (error-text (& why))))))
     g))
 
 (define (host-in [dir string] [env (slice string)] [g (ptr grants)] [args (slice string)] [input (slice u8)]) -> ran
-  (program-in dir (joined-path (root) "substrate/host/subhost.mjs") env
+  (program-in dir (toolchain-host) env
               (grants-arguments g (@ args 0) (slice args 1 (-> args length))) input))
 
 (define (sub-in [dir string] [clauses (slice (slice string))] [env (slice string)] [args (slice string)]
@@ -72,8 +73,8 @@
         [compare (compare-output! (-> r output) expected message)]))
 
 (define (expected-text [path string]) -> string
-  (let ([bytes (slice u8)] [why string])
-    (when (< (fs-read-file path (& bytes) (& why)) 0) (throw test-failed (joined (joined path ": ") why)))
+  (let ([bytes (slice u8)] [why error])
+    (unless (fs-read-file path (& bytes) (& why)) (throw test-failed (joined (joined path ": ") (error-text (& why)))))
     (cast string bytes)))
 
 (define (sub-run-in [dir string] [name string] [grants (slice string)]) -> ran

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 "")
 
@@ -102,12 +98,12 @@
     (when (and (digits-integer (option "-t") 10 #f (& n)) (> n 0)) (set! at-once (cast u32 n)))
     (when (digits-integer (option "--timeout-ms") 10 #f (& n)) (set! time-limit n)))
   (for ([i u32 0]) (< i (-> arguments length)) (+= i 1)
-    (let ([a (@ arguments i)] [why string])
+    (let ([a (@ arguments i)])
       (cond [(== a "-v") (set! verbose #t)]
             [(== a "--ignored") (set! ignored-only #t)]
             [(== a "--nocapture") (set! capturing #f)]
             [(and (== a "--grant") (< (+ i 2) (-> arguments length)))
-             (grants-add! (& needs) (@ arguments (+ i 1)) (slice (& (@ arguments (+ i 2))) 1) (& why))
+             (grants-add! (& needs) (@ arguments (+ i 1)) (slice (& (@ arguments (+ i 2))) 1) 0)
              (+= i 2)]))))
 
 (define (valued? [a string]) -> bool (or (== a "--name") (== a "-t") (== a "--timeout-ms")))
@@ -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!))
 
@@ -202,9 +205,9 @@
 ;; Returns #t if the test is now running in slot s, or #f if it could not start.
 (define (started! [s (ptr slot)] [e (ptr entry)]) -> bool
   (set! (-> s captured length) 0)
-  (let ([o worker-options] [why string] [scratch (scratch-of e)])
-    (when (< (fs-make-dir scratch (& why)) 0)
-      (failed! e why "")
+  (let ([o worker-options] [why error] [scratch (scratch-of e)])
+    (unless (fs-make-dir scratch (& why))
+      (failed! e (error-text (& why)) "")
       (return #f))
     (env-set "SUBSTRATE_SCRATCH" scratch 0)
     (worker-options-init! (& o))
@@ -216,17 +219,20 @@
     (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))
-          (failed! e 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 (error-text (& why)) "")
           (return #f))))
     (set! (-> s entry) e)
     (set! (-> s head handle) heard)
-    (set! (-> s worker) (worker-start (-> e run) (slice (cast (ptr u8) 0) 0) (& o) (cast (ptr void) (& (-> s head)))
-                                      (& why)))
-    (when (== (-> s worker) 0)
-      (failed! e (beyond why) "")
+    (unless (worker-start (-> e run) (slice (cast (ptr u8) 0) 0) (& o) (cast (ptr void) (& (-> s head)))
+                          (& (-> s worker)) (& why))
+      (failed! e (beyond (error-text (& why))) "")
       (return #f))
     (when (> time-limit 0)
       (set! (-> s clock handle) out-of-time)
@@ -419,12 +425,12 @@
     (output-differs! got expected message)))
 
 (define (compare-output-file! [got string] [module string] [file string] [message string])
-  (let ([why string] [bytes (slice u8)] [path (test-path module file)])
-    (when (< (fs-read-file path (& bytes) (& why)) 0)
+  (let ([why error] [bytes (slice u8)] [path (test-path module file)])
+    (unless (fs-read-file path (& bytes) (& why))
       (let ([b (make-buffer)])
         (buffer-add-string! (& b) message)
         (buffer-add-byte! (& b) 10)
-        (buffer-add-string! (& b) why)
+        (buffer-add-string! (& b) (error-text (& why)))
         (throw test-failed (buffer-string (& b)))))
     (unless (== (trimmed got) (trimmed (cast string bytes))) (output-differs! got (cast string bytes) message))
     (free (-> bytes items))))

package/std/vector/vector.sub

@@ -0,0 +1,75 @@
+;; Vectors: growable arrays of one type, on the heap. (define-vector name type) declares the type name, whose zero value
+;; is an empty vector, and its functions name-count, name-items, name-at, name-at-unchecked, name-add!, name-push!,
+;; name-pop!, name-clear!, name-reserve! and name-free!. vector-count, vector-at and the others call the function of
+;; their first argument's type, and vector-each runs its body for each item. Growing may move the items, so a pointer
+;; to an item lasts until the vector next grows.
+(require-unqualified std/meta/method)
+
+(provide define-vector vector-count vector-items vector-at vector-at-unchecked vector-add! vector-push! vector-pop!
+         vector-clear! vector-reserve! vector-free! vector-each)
+
+(begin-for-syntax
+  (require-unqualified compiler/macros)
+  (require-unqualified std/meta/type-info)
+
+  (define (define-vector-form [s datum]) -> datum
+    (syntax-match s
+      [(_ (? identifier? name) t)
+       (let ([count (method-name name '-count)] [items (method-name name '-items)] [at (method-name name '-at)]
+             [at-unchecked (method-name name '-at-unchecked)] [add (method-name name '-add!)]
+             [push (method-name name '-push!)] [pop (method-name name '-pop!)] [clear (method-name name '-clear!)]
+             [reserve (method-name name '-reserve!)] [free! (method-name name '-free!)])
+         #`(begin
+             (struct #,name [items (ptr #,t)] [count u32] [room u32])
+             (define (#,count [v (ptr #,name)]) -> u32 (-> v count))
+             (define (#,items [v (ptr #,name)]) -> (slice #,t) (slice (-> v items) (-> v count)))
+             (define (#,at [v (ptr #,name)] [i u32]) -> (ptr #,t) (& (@ (slice (-> v items) (-> v count)) i)))
+             (define (#,at-unchecked [v (ptr #,name)] [i u32]) -> (ptr #,t) (+ (-> v items) i))
+             (define (#,reserve [v (ptr #,name)] [n u32])
+               (when (> n (-> v room))
+                 (let ([room u64 (if (== (-> v room) 0) 4 (cast u64 (-> v room)))])
+                   (while (< room (cast u64 n)) (set! room (* room 2)))
+                   (let ([bytes (* room (cast u64 (sizeof #,t)))])
+                     (set! (-> v items)
+                           (cast (ptr #,t) (realloc (-> v items) (if (< bytes 2147483584) (cast u32 bytes) 2147483584))))
+                     (set! (-> v room) (cast u32 room))))))
+             (define (#,push [v (ptr #,name)] [x #,t])
+               (when (== (-> v count) (-> v room)) (#,reserve v (+ (-> v count) 1)))
+               (set! (@ (+ (-> v items) (-> v count))) x)
+               (+= (-> v count) 1))
+             (define (#,add [v (ptr #,name)]) -> (ptr #,t)
+               (when (== (-> v count) (-> v room)) (#,reserve v (+ (-> v count) 1)))
+               (let ([p (+ (-> v items) (-> v count))])
+                 (memset p 0 (sizeof #,t))
+                 (+= (-> v count) 1)
+                 p))
+             (define (#,pop [v (ptr #,name)]) -> #,t
+               (when (== (-> v count) 0) (host-trap "vector-pop!: the vector is empty"))
+               (-= (-> v count) 1)
+               (@ (+ (-> v items) (-> v count))))
+             (define (#,clear [v (ptr #,name)]) (set! (-> v count) 0))
+             (define (#,free! [v (ptr #,name)])
+               (free (-> v items))
+               (set! (-> v items) 0)
+               (set! (-> v count) 0)
+               (set! (-> v room) 0))))]
+      [_ (raise-syntax-error 'define-vector "expected (define-vector name type)" s)]))
+
+  (define (vector-each-form [s datum]) -> datum
+    (syntax-match s
+      [(_ (((? identifier? x) v)) body0 body ...)
+       #`(let ([the-vector #,v])
+           (for ([i u32 0]) (< i (vector-count the-vector)) (+= i 1)
+             (let ([#,x (vector-at-unchecked the-vector i)]) #,body0 #,@body)))]
+      [(_ (((? identifier? x) (? identifier? i) v)) body0 body ...)
+       #`(let ([the-vector #,v])
+           (for ([#,i u32 0]) (< #,i (vector-count the-vector)) (+= #,i 1)
+             (let ([#,x (vector-at-unchecked the-vector #,i)]) #,body0 #,@body)))]
+      [_ (raise-syntax-error
+          'vector-each "expected (vector-each ([item vector]) body ...) or (vector-each ([item index vector]) body ...)" s)])))
+
+(define-syntax define-vector define-vector-form)
+(define-syntax vector-each vector-each-form)
+(define-methods [vector-count -count] [vector-items -items] [vector-at -at] [vector-at-unchecked -at-unchecked]
+                [vector-add! -add!] [vector-push! -push!] [vector-pop! -pop!] [vector-clear! -clear!]
+                [vector-reserve! -reserve!] [vector-free! -free!])

package/substrate/VERSION

@@ -1 +1 @@
-0.9.3
+0.10.0

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)))