substrate-lang 0.9.4 → 0.10.0

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,8 +77,8 @@
 
 (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 (new 0 page)])
     (+= opened 1)
@@ -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,20 +21,21 @@
 ;; ---- 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
@@ -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

@@ -98,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")))
@@ -205,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))
@@ -226,14 +226,13 @@
               (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 "")
+          (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)
@@ -426,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.4
+0.10.0