substrate-lang 0.9.4 → 0.10.0

package/README.md

@@ -1,7 +1,7 @@
 # substrate-lang
 
 Substrate is a Lisp for writing WebAssembly. It has C-like semantics
-(modernized with generics, variants, bounds-checked slices), combined with
+(modernized with variants and bounds-checked slices), combined with
 Racket-style hygienic macros and module hooks for defining new languages and
 DSLs. Its compiler is small (~11k LOC, <600 KiB of Wasm), very fast,
 self-hosted, and runs in the browser.

package/build/compiler/program

@@ -1,21 +1,21 @@
-substrate.728c690187f2@0+0
-writer.550227768eb9@0+0
-syntax.fadc832db29f@0+0
-path.1b5fd988b6f3@0+0
-fs.5017b627cbd2@0+0
-reader.d256e69e09e2@0+0
-roots.e366210c01d6@0+0
-running.b99787c2d180@0+0
-core.0410ffbdc488@0+0
-ops.324f0a665fab@0+0
-checker.2b0ea87ed311@0+0
-leb128.ba77430f659f@0+0
-binary.cdd2ffb408dd@0+0
-serialize.a12536bbbe9a@0+0
-compile.da85f9bc4478@0+0
-sha256.f6c742932dde@0+0
-link.be6e641afa93@0+0
-macros.b695763c0ca3@0+0
-expander.80707e1666d6@0+0
-prune.29dde307bdee@0+0
-main.cbbdf42e34c2@0+0
+substrate.5ee5d0b4d3e7@0+0
+writer.00b7802cbe39@0+0
+syntax.32f3e40b61c7@0+0
+path.5a6286472cd4@0+0
+fs.01b8aab4a9a8@0+0
+reader.694b03770bf0@0+0
+roots.cefd10e93684@0+0
+running.0d25dbaec018@0+0
+core.f2defb75e00b@0+0
+ops.515b5e05f646@0+0
+checker.4dd4556dd421@0+0
+leb128.15d814b7b4f2@0+0
+binary.2d43b43d1600@0+0
+serialize.b0d82f3d63d2@0+0
+compile.5d8f6407af2a@0+0
+sha256.a6c32b04d799@0+0
+link.b826ea7c8f17@0+0
+macros.b269e0c42784@0+0
+expander.967ce443d379@0+0
+prune.406215c3e4f8@0+0
+main.4fc52f204d54@0+0

package/build/sub/program

@@ -1,48 +1,48 @@
-substrate.728c690187f2@0+0
-process.ca10ac0b8a62@0+0
-path.1b5fd988b6f3@0+0
-path.de22f6659534@0+0
-fs.5017b627cbd2@0+0
-common.997c21b0b8cf@0+0
-grants.cd99dff2854e@0+0
-writer.550227768eb9@0+0
-syntax.fadc832db29f@0+0
-reader.d256e69e09e2@0+0
-roots.e366210c01d6@0+0
-read.279fafcda508@0+0
-manifest.6e014ac19e5d@0+0
-git.1c5791236e35@0+0
-files.1706cc0941c0@0+0
-sha256.f6c742932dde@0+0
-hash.ba8330dad9ff@0+0
-store.c48db3345968@0+0
-map.e582eae03ec2@0+0
-env.861d55fff974@0+0
-events.2c981f6f1ec7@0+0
-build.115aeefc15e8@0+0
-pack.4295e4f5bdbd@0+0
-site.e6e415bc3170@0+0
-site.76aa8286c257@0+0
-fetch.d62aa5fc9623@0+0
-stream.27fd2fe858e1@0+0
-worker.ea1e11f8f5e2@0+0
-deflate.3138a38325a1@0+0
-inflate.3cfa17586072@0+0
-gzip.9ebea150f218@0+0
-tar.692c0e8827cd@0+0
-fetch.b0ce8f8b3da8@0+0
-doc.f18ad14060e9@0+0
-html.3b3c8d7d9971@0+0
-html.0b0362932a75@0+0
-text.8ff142d72fd7@0+0
-root.02141d04d568@0+0
-doc.e3f9a998cd91@0+0
-timer.d3454726b3bf@0+0
-chromium.fc0bfea0fbe6@0+0
-test.1fd2ff8123bf@0+0
-utf8.e82afeb9e953@0+0
-json.af2e0ae20084@0+0
-sha512.9fee24e95460@0+0
-base64.454b045156d2@0+0
-upgrade.2a9219e6a45d@0+0
-sub.c0fb7310de12@0+0
+substrate.5ee5d0b4d3e7@0+0
+process.7106571fa723@0+0
+path.5a6286472cd4@0+0
+path.6891ffea73ca@0+0
+fs.01b8aab4a9a8@0+0
+common.1edc613607a0@0+0
+grants.c54776c0d7e3@0+0
+writer.00b7802cbe39@0+0
+syntax.32f3e40b61c7@0+0
+reader.694b03770bf0@0+0
+roots.cefd10e93684@0+0
+read.0b93933d62a2@0+0
+manifest.ef317480deb0@0+0
+git.dc4c0e757ebe@0+0
+files.ad0469fdf6fa@0+0
+sha256.a6c32b04d799@0+0
+hash.660682e4f491@0+0
+store.a24d7a25daa6@0+0
+map.f455cca6a42a@0+0
+env.e5451da6e747@0+0
+events.bf5473ebf220@0+0
+build.459c5b9412bd@0+0
+pack.e02836264f6a@0+0
+site.ae3913b0b0f4@0+0
+site.1732b58ec0e8@0+0
+fetch.7790d4943758@0+0
+stream.126e3bd5d626@0+0
+worker.762a9d642af0@0+0
+deflate.23f7c4679260@0+0
+inflate.59bb61f14001@0+0
+gzip.16e372eda1cf@0+0
+tar.2a633861e654@0+0
+fetch.96b2d10f025e@0+0
+doc.ef9965d5d402@0+0
+html.e9ed37f34977@0+0
+html.a23126eb949a@0+0
+text.1bc90482bd43@0+0
+root.f10a4906f460@0+0
+doc.0775df5de6fe@0+0
+timer.f35eb62ae446@0+0
+chromium.3d5818f2707d@0+0
+test.9bd59c73f65e@0+0
+utf8.e7216bd054e1@0+0
+json.55590d2f518a@0+0
+sha512.c24a792d7891@0+0
+base64.a26bdcf60a2d@0+0
+upgrade.39ee449b00d5@0+0
+sub.2e3092140706@0+0

package/package.json

@@ -1,6 +1,6 @@
 {
   "name": "substrate-lang",
-  "version": "0.9.4",
+  "version": "0.10.0",
   "description": "A Lisp for writing WebAssembly, and the substrate command that builds, runs and tests it",
   "license": "MIT",
   "repository": {

package/std/archive/tar.sub

@@ -14,15 +14,17 @@
   (set! (-> r at) 0))
 
 ;; An entry's path is in a or the data, and a file's bytes are in the data.
-(define (tar-next! [a (ptr arena)] [r (ptr tar-reader)] [e (ptr tar-entry)] [err (ptr buffer)]) -> i32
+(define (tar-next! [a (ptr arena)] [r (ptr tar-reader)] [e (ptr tar-entry)] [found (ptr bool)] [err (ptr buffer)])
+  -> bool
   (let ([long string] [sized #f] [given-size u64 0])
+    (set! (@ found) #f)
     (while #t
       (let* ([data (-> r data)] [at (-> r at)] [left (- (-> data length) at)] [h (slice u8)] [size u64 0] [type u8 0]
              [body (slice u8)] [next u64 0])
-        (when (== left 0) (return 0))
+        (when (== left 0) (return #t))
         (when (< left 512) (return (bad! err "the archive is cut short")))
         (set! h (slice data at (+ at 512)))
-        (when (zeros? h) (return 0))
+        (when (zeros? h) (return #t))
         (unless (summed? h) (return (bad! err "a header's checksum is wrong")))
         (unless (octal h 124 12 (& size)) (return (bad! err "a header's size is not a number")))
         (when sized (set! size given-size))
@@ -41,38 +43,43 @@
                                        [else tar-other]))
                (set! (-> e path) (if (> (-> long length) 0) long (header-path a h)))
                (set! (-> e bytes) (if (== (-> e kind) tar-file) body (slice body 0 0)))
-               (return 1)])))))
+               (set! (@ found) #t)
+               (return #t)])))))
 
-;; tar-unpack! gives 0, or -1 when data is not a tar archive and -2 when a file cannot be written, with err saying why.
-(define (tar-unpack! [a (ptr arena)] [data (slice u8)] [dir string] [err (ptr buffer)]) -> i32
-  (let ([r tar-reader] [e tar-entry] [got i32 1] [top ""] [one #t] [why string])
+(define (tar-unpack! [a (ptr arena)] [data (slice u8)] [dir string] [err (ptr buffer)]) -> bool
+  (let ([r tar-reader] [e tar-entry] [found #t] [top ""] [one #t] [why error] [reason (make-buffer)])
     (tar-reader-init! (& r) data)
-    (while (== got 1)
-      (set! got (tar-next! a (& r) (& e) err))
-      (when (and (== got 1) (!= (-> e kind) tar-other))
+    (while found
+      (unless (tar-next! a (& r) (& e) (& found) (& reason))
+        (buffer-add-string! err "not a tar archive: ")
+        (buffer-add! err (buffer-bytes (& reason)))
+        (buffer-free! (& reason))
+        (return #f))
+      (when (and found (!= (-> e kind) tar-other))
         (let ([p (cleaned (-> e path))])
           (when (> (-> p length) 0)
             (when (== (-> top length) 0) (set! top (first-part p)))
             (unless (or (and (== p top) (== (-> e kind) tar-directory)) (inside-top? p top)) (set! one #f))))))
-    (when (< got 0) (return -1))
+    (buffer-free! (& reason))
     (tar-reader-init! (& r) data)
-    (set! got 1)
-    (while (== got 1)
-      (set! got (tar-next! a (& r) (& e) err))
-      (when (and (== got 1) (!= (-> e kind) tar-other))
+    (set! found #t)
+    (while found
+      (tar-next! a (& r) (& e) (& found) err)
+      (when (and found (!= (-> e kind) tar-other))
         (let ([p (cleaned (-> e path))])
           (when (and one (> (-> top length) 0)) (set! p (if (== p top) "" (slice p (+ (-> top length) 1)))))
           (when (> (-> p length) 0)
             (let ([full (under a dir p)])
-              (when (or (and (== (-> e kind) tar-directory) (< (fs-make-dir full (& why)) 0))
+              (when (or (and (== (-> e kind) tar-directory) (not (fs-make-dir full (& why))))
                         (and (== (-> e kind) tar-file)
-                             (or (< (fs-make-dir (up-to-last-slash full) (& why)) 0)
-                                 (< (fs-write-file full (-> e bytes) (& why)) 0))))
+                             (not (and (fs-make-dir (up-to-last-slash full) (& why))
+                                       (fs-write-file full (-> e bytes) (& why))))))
                 (buffer-add-string! err p)
                 (buffer-add-string! err ": ")
-                (buffer-add-string! err why)
-                (return -2)))))))
-    0))
+                (buffer-add-string! err (error-text (& why)))
+                (error-free! (& why))
+                (return #f)))))))
+    #t))
 
 (define (cleaned [p string]) -> string
   (let ([s p])
@@ -100,9 +107,9 @@
     (while (and (> i 0) (!= (@ p (- i 1)) #\/)) (-= i 1))
     (if (<= i 1) "/" (slice p 0 (- i 1)))))
 
-(define (bad! [err (ptr buffer)] [why string]) -> i32
+(define (bad! [err (ptr buffer)] [why string]) -> bool
   (buffer-add-string! err why)
-  -1)
+  #f)
 
 (define (zeros? [h (slice u8)]) -> bool
   (for ([i u32 0]) (< i (-> h length)) (+= i 1) (when (!= (@ h i) 0) (return #f)))

package/std/browser/chromium.sub

@@ -16,7 +16,7 @@
                  [stopped (fn ((ptr chromium)))])
 
 (define (chromium-start [c (ptr chromium)] [file string] [profile string] [args (slice string)] [ms f64]
-                        [started (fn ((ptr chromium)))] [err (ptr string)]) -> bool
+                        [started (fn ((ptr chromium)))] [err (ptr error)]) -> bool
   (let ([argv (make-buffer)] [o process-options] [profile-flag (make-buffer)]
         [fixed (slice (array-of string "--headless=new" "--remote-debugging-port=0" "--no-first-run"
                                 "--no-default-browser-check" "--no-sandbox" "--mute-audio"
@@ -41,9 +41,10 @@
     (process-options-init! (& o))
     (set! (-> o stdin) process-ignore)
     (set! (-> o stdout) process-ignore)
-    (set! (-> c id) (process-spawn file (strings-in (& argv)) (& o) (cast (ptr void) (& (-> c head))) err))
-    (buffer-free! (& argv))
-    (when (== (-> c id) 0) (return #f))
+    (let ([spawned (process-spawn file (strings-in (& argv)) (& o) (cast (ptr void) (& (-> c head))) (& (-> c id))
+                                  err)])
+      (buffer-free! (& argv))
+      (unless spawned (return #f)))
     (set! (-> c running) #t)
     (stream-tag! (process-stderr (-> c id)) (cast (ptr void) (& (-> c head))))
     (stream-read! (process-stderr (-> c id)) (slice (-> c chunk)))

package/std/browser/devtools.sub

@@ -27,11 +27,12 @@
 (define socket-head event-head)
 
 (define (relay)
-  (let ([why string])
+  (let ([why error] [id u32 0])
     (event-handler! worker-source from-parent)
     (set! (-> socket-head handle) from-socket)
-    (set! socket (websocket-connect (@ (host-args) 0) 0 (cast (ptr void) (& socket-head)) (& why)))
-    (when (== socket 0) (host-exit 1 why))))
+    (unless (websocket-connect (@ (host-args) 0) 0 (cast (ptr void) (& socket-head)) (& id) (& why))
+      (host-exit 1 (error-text (& why))))
+    (set! socket id)))
 
 (define (from-parent [source u32] [kind u32] [id u32] [tag (ptr void)] [value i32])
   (when (and (== kind worker-message) (== id 0))
@@ -55,7 +56,7 @@
 ;; ---- the connection ----
 
 (define (devtools-connect [d (ptr devtools)] [address string] [handler (fn ((ptr devtools) string (ptr json-value) string))]
-                          [state (ptr void)] [err (ptr string)]) -> bool
+                          [state (ptr void)] [err (ptr error)]) -> bool
   (let ([text string] [deadline (+ (clock-monotonic) patience)])
     (set! (-> d head handle) relay-heard)
     (set! (-> d next) 0)
@@ -65,11 +66,13 @@
     (set! (-> d awaited) (make-buffer))
     (set! (-> d kept) (make-buffer))
     (set! (-> d why) "")
-    (set! (-> d relay) (worker-start relay (cast (slice u8) address) 0 (cast (ptr void) (& (-> d head))) err))
-    (when (== (-> d relay) 0) (return #f))
+    (unless (worker-start relay (cast (slice u8) address) 0 (cast (ptr void) (& (-> d head))) (& (-> d relay)) err)
+      (return #f))
     (while #t
       (unless (next! d deadline (& text))
-        (set! (@ err) (if (> (-> d why length) 0) (-> d why) "Chromium did not take a DevTools connection within 30 s"))
+        (if (> (-> d why length) 0)
+            (error-fail! err error-other (-> d why))
+            (error-fail! err error-timeout "Chromium did not take a DevTools connection within 30 s"))
         (devtools-close d)
         (return #f))
       (let ([open (== text "open")])
@@ -137,49 +140,51 @@
     (-> d next)))
 
 (define (devtools-call [d (ptr devtools)] [a (ptr arena)] [method string] [parameters string] [session string]
-                       [result (ptr (ptr json-value))] [err (ptr string)]) -> bool
+                       [result (ptr (ptr json-value))] [err (ptr error)]) -> bool
   (let ([id (devtools-send d method parameters session)] [deadline (+ (clock-monotonic) patience)] [text string]
         [ok #f] [done #f])
     (buffer-add-u32! (& (-> d awaited)) id)
     (while (not done)
       (cond [(or (taken! d id (& text)) (next! d deadline (& text)))
-             (let ([e (make-arena)] [je json-error] [m (ptr json-value) 0] [rid i64 0])
-               (set! m (json-parse (& e) text (& je)))
+             (let ([e (make-arena)] [m (ptr json-value) 0] [rid i64 0])
+               (json-parse (& e) text (& m) 0)
                (free (-> text bytes))
                (cond [(== m 0) (begin)]
                      [(json-as-i64 (json-get m "id") (& rid))
                       (cond [(== (cast u32 rid) id)
                              (set! done #t)
-                             (let ([error (json-get m "error")] [r (json-get m "result")] [why string])
-                               (if (== error 0)
+                             (let ([refusal (json-get m "error")] [r (json-get m "result")] [why string])
+                               (if (== refusal 0)
                                    (begin
                                      (set! (@ result) (if (== r 0) 0 (json-copy a r)))
                                      (set! ok #t))
-                                   (let ([b (make-buffer)] [message (json-get error "message")])
+                                   (let ([b (make-buffer)] [message (json-get refusal "message")])
                                      (json-as-string message (& why))
                                      (buffer-add-string! (& b) method)
                                      (buffer-add-string! (& b) ": ")
                                      (buffer-add-string! (& b) why)
-                                     (set! (@ err) (buffer-string (& b))))))]
+                                     (error-fail! err error-other (buffer-string (& b)))
+                                     (buffer-free! (& b)))))]
                             [(awaited? d (cast u32 rid)) (kept! d (cast u32 rid) m)]
                             [else (begin)])]
                      [else (heard! d m)])
                (arena-free (& e)))]
             [else
              (set! done #t)
-             (let ([b (make-buffer)])
+             (let ([b (make-buffer)] [late (== (-> d why length) 0)])
                (buffer-add-string! (& b) method)
                (buffer-add-string! (& b) ": ")
-               (buffer-add-string! (& b) (if (> (-> d why length) 0) (-> d why) "Chromium did not answer within 30 s"))
-               (set! (@ err) (buffer-string (& b))))]))
+               (buffer-add-string! (& b) (if late "Chromium did not answer within 30 s" (-> d why)))
+               (error-fail! err (if late error-timeout error-other) (buffer-string (& b)))
+               (buffer-free! (& b)))]))
     (-= (-> d awaited length) 4)
     ok))
 
 (define (devtools-pump [d (ptr devtools)] [ms f64])
   (let ([deadline (+ (clock-monotonic) ms)] [text string])
     (while (next! d deadline (& text))
-      (let ([e (make-arena)] [je json-error] [m (ptr json-value) 0] [rid i64 0])
-        (set! m (json-parse (& e) text (& je)))
+      (let ([e (make-arena)] [m (ptr json-value) 0] [rid i64 0])
+        (json-parse (& e) text (& m) 0)
         (free (-> text bytes))
         (cond [(== m 0) (begin)]
               [(json-as-i64 (json-get m "id") (& rid)) (when (awaited? d (cast u32 rid)) (kept! d (cast u32 rid) m))]

package/std/compress/gzip.sub

@@ -1,9 +1,9 @@
 ;; The gzip format (RFC 1952) around DEFLATE data, and its CRC-32. gunzip! decodes whole gzip data, each member in
-;; turn, adding at most most bytes to out, and returns 0 or a negative code whose message gzip-message gives.
+;; turn, adding at most most bytes to out.
 (require-unqualified "inflate.sub")
 (require-unqualified "deflate.sub")
 
-(provide crc32 gunzip! gzip-message gzip-start! gzip-end! gzip!)
+(provide crc32 gunzip! gzip-start! gzip-end! gzip!)
 
 ;; CRC-32 with eight tables, slicing eight bytes at a time.
 (define tables (array u32 2048))
@@ -82,7 +82,9 @@
     [(-105) "incorrect data check"]
     [(-106) "incorrect length check"]
     [(-107) "unexpected end of data"]
-    [else (inflate-message code)]))
+    [else "no error"]))
+
+(define (refused [err (ptr error)] [code i32]) -> bool (error-fail! err error-invalid (gzip-message code)))
 
 (define (le32 [p (ptr u8)]) -> u32
   (bit-or (cast u32 (@ p 0)) (<< (cast u32 (@ p 1)) 8) (<< (cast u32 (@ p 2)) 16) (<< (cast u32 (@ p 3)) 24)))
@@ -114,19 +116,19 @@
       (+= i 2))
     (cast i32 i)))
 
-(define (gunzip! [out (ptr buffer)] [in (slice u8)] [most u32]) -> i32
+(define (gunzip! [out (ptr buffer)] [in (slice u8)] [most u32] [err (ptr error)]) -> bool
   (let ([at u32 0] [start (-> out length)])
     (while #t
       (let* ([rest (slice in at)] [h (header-length rest)] [used u32 0] [begun (-> out length)])
-        (when (< h 0) (return h))
-        (let ([result (inflate! out (slice rest (cast u32 h)) (- most (- begun start)) (& used))])
-          (unless (== result 0) (return result))
-          (let ([trailer (+ (cast u32 h) used)])
-            (when (< (- (-> rest length) trailer) 4) (return short-header))
-            (unless (== (le32 (+ (-> rest items) trailer)) (crc32 0 (slice (buffer-bytes out) begun)))
-              (return bad-data-check))
-            (when (< (- (-> rest length) trailer) 8) (return short-header))
-            (unless (== (le32 (+ (-> rest items) trailer 4)) (- (-> out length) begun)) (return bad-length-check))
-            (+= at (+ trailer 8))
-            (when (== at (-> in length)) (return 0))))))
-    0))
+        (when (< h 0) (return (refused err h)))
+        (unless (inflate! out (slice rest (cast u32 h)) (- most (- begun start)) (& used) err) (return #f))
+        (let ([trailer (+ (cast u32 h) used)])
+          (when (< (- (-> rest length) trailer) 4) (return (refused err short-header)))
+          (unless (== (le32 (+ (-> rest items) trailer)) (crc32 0 (slice (buffer-bytes out) begun)))
+            (return (refused err bad-data-check)))
+          (when (< (- (-> rest length) trailer) 8) (return (refused err short-header)))
+          (unless (== (le32 (+ (-> rest items) trailer 4)) (- (-> out length) begun))
+            (return (refused err bad-length-check)))
+          (+= at (+ trailer 8))
+          (when (== at (-> in length)) (return #t)))))
+    #t))