substrate-lang 0.9.4 → 0.10.0

package/std/compress/inflate.sub

@@ -1,7 +1,6 @@
 ;; DEFLATE decoding (RFC 1951) of whole buffers, with lookup tables as zlib and libdeflate decode. inflate! decodes the
-;; data at the start of in, adding at most most bytes to out, sets used to the bytes it took, and returns 0 or a negative
-;; code whose message, zlib's, inflate-message gives.
-(provide inflate! inflate-message)
+;; data at the start of in, adding at most most bytes to out, and sets used to the bytes it took.
+(provide inflate!)
 
 ;; Table entries hold a code's length in bits, an op and a value. Op 0 is a literal, 16 plus a count of extra bits a
 ;; base length or distance, 32 the end of a block, 64 plus a width a link to the table of that many bits at the value,
@@ -279,7 +278,11 @@
                        (+= (-> out length) n)))))])))
     0))
 
-(define (inflate! [out (ptr buffer)] [in (slice u8)] [most u32] [used (ptr u32)]) -> i32
+(define (inflate! [out (ptr buffer)] [in (slice u8)] [most u32] [used (ptr u32)] [err (ptr error)]) -> bool
+  (let ([code (inflate-code! out in most used)])
+    (or (== code 0) (error-fail! err (if (== code too-large) error-other error-invalid) (inflate-message code)))))
+
+(define (inflate-code! [out (ptr buffer)] [in (slice u8)] [most u32] [used (ptr u32)]) -> i32
   (let ([r reader] [last #f] [result i32 0])
     (unless fixed (fixed!))
     (set! (-> r bits) 0)

package/std/crypto/password.sub

@@ -62,10 +62,10 @@
   (set! last j)
   (when (== first j)
     (when (== running 0)
-      (let ([why string])
+      (let ([why error] [id u32 0])
         (set! (-> listener handle) answered)
-        (set! running (worker-start password-worker 0 0 (& listener) (& why)))
-        (when (== running 0) (host-trap why))))
+        (unless (worker-start password-worker 0 0 (& listener) (& id) (& why)) (host-trap (error-text (& why))))
+        (set! running id)))
     (send-first!)))
 
 (define (unpadded! [b (ptr buffer)] [bytes (slice u8)])

package/std/doc/doc.sub

@@ -45,7 +45,7 @@
     id))
 
 (define (text-of [id datum]) -> string
-  (let ([b (slice u8)] [why string]) (if (< (fs-read-file (datum->string (host-file id)) (& b) (& why)) 0) "" (cast string b))))
+  (let ([b (slice u8)]) (if (fs-read-file (datum->string (host-file id)) (& b) 0) (cast string b) "")))
 
 (define (forms-of [text string] [id datum]) -> datum (program-forms (read-all text (string->symbol (datum->string id)))))
 
@@ -103,7 +103,7 @@
 (define (described [id datum]) -> datum
   (let ([known (assoc id descriptions)] [info fs-info] [forms datum 0] [d datum 0] [spec datum 0] [next datum 0])
     (unless (== known 0) (return (cdr known)))
-    (when (and (== (fs-stat (datum->string (host-file id)) (& info) 0) 0) (== (-> info kind) fs-file))
+    (when (and (fs-stat (datum->string (host-file id)) (& info) 0) (== (-> info kind) fs-file))
       (set! forms (forms-of (text-of id) id))
       (set! d (doc-forms-of forms))
       (set! spec (language-of forms))

package/std/encoding/json.sub

@@ -22,7 +22,7 @@
 
 (struct json-member [key string] [value json-value])
 
-(struct json-error [message string] [offset u32] [line u32] [column u32])
+(struct json-error [error error] [offset u32] [line u32] [column u32])
 
 ;; ---- the token reader ----
 
@@ -49,12 +49,15 @@
   (set! (-> r token) "")
   (set! (-> r number) 0.0)
   (set! (-> r scratch) (make-buffer))
-  (set! (-> r error message) "")
+  (set! (-> r error error code) 0)
+  (set! (-> r error error message) (make-buffer))
   (set! (-> r error offset) 0)
   (set! (-> r error line) 0)
   (set! (-> r error column) 0))
 
-(define (json-reader-free! [r (ptr json-reader)]) (buffer-free! (& (-> r scratch))))
+(define (json-reader-free! [r (ptr json-reader)])
+  (buffer-free! (& (-> r scratch)))
+  (error-free! (& (-> r error error))))
 
 (define (json-next! [r (ptr json-reader)]) -> json-token
   (let ([s (-> r state)] [c (space! r)])
@@ -153,7 +156,7 @@
       (when (== (@ p i) 10)
         (+= line 1)
         (set! from (+ i 1))))
-    (set! (-> r error message) message)
+    (error-fail! (& (-> r error error)) error-invalid message)
     (set! (-> r error offset) (-> r at))
     (set! (-> r error line) line)
     (set! (-> r error column) (+ (- (-> r at) from) 1))
@@ -162,6 +165,14 @@
 
 (define (reject! [r (ptr json-reader)] [message string]) -> bool (fail! r message) #f)
 
+(define (failed-into! [r (ptr json-reader)] [err (ptr json-error)]) -> bool
+  (unless (== err 0)
+    (error-fail! (& (-> err error)) (-> r error error code) (error-text (& (-> r error error))))
+    (set! (-> err offset) (-> r error offset))
+    (set! (-> err line) (-> r error line))
+    (set! (-> err column) (-> r error column)))
+  #f)
+
 (define (string! [r (ptr json-reader)]) -> bool
   (let ([p (-> r text bytes)] [start (-> r at)] [i (-> r at)] [end (-> r text length)] [c u32 0] [k u32 0])
     (while (< i end)
@@ -306,7 +317,7 @@
 
 (define (arena-text [a (ptr arena)] [s string]) -> string (copy a s))
 
-(define (json-parse [a (ptr arena)] [text string] [err (ptr json-error)]) -> (ptr json-value)
+(define (json-parse [a (ptr arena)] [text string] [value (ptr (ptr json-value))] [err (ptr json-error)]) -> bool
   (let ([r json-reader] [values (make-buffer)] [members (make-buffer)] [starts (array u32 1000)]
         [root (ptr json-value) 0] [t json-token] [v json-value (json-null)] [k u32 0] [m json-member] [placed #f])
     (json-reader-start! (& r) text)
@@ -345,7 +356,7 @@
              (set! (-> members length) (* (@ starts (-> r depth)) (sizeof json-member)))]
             [(== t json-token-end) (break)]
             [else
-             (when (!= err 0) (set! (@ err) (-> r error)))
+             (failed-into! (& r) err)
              (set! root 0)
              (break)])
       (when placed
@@ -360,7 +371,8 @@
     (json-reader-free! (& r))
     (buffer-free! (& values))
     (buffer-free! (& members))
-    root))
+    (set! (@ value) root)
+    (!= root 0)))
 
 ;; The k items of size bytes from index from of bytes, copied into a, or 0 for none.
 (define (block [a (ptr arena)] [bytes (ptr u8)] [from u32] [k u32] [size u32]) -> (ptr void)
@@ -722,7 +734,7 @@
 (define (end-of-text! [r (ptr json-reader)]) -> bool (== (json-next! r) json-token-end))
 
 (define (finish! [r (ptr json-reader)] [ok bool] [err (ptr json-error)]) -> bool
-  (when (and (not ok) (!= err 0)) (set! (@ err) (-> r error)))
+  (unless ok (failed-into! r err))
   (json-reader-free! r)
   ok)
 

package/std/encoding/wire.sub

@@ -3,9 +3,9 @@
 
 (provide wire wire-error)
 
-(struct wire-error [message string] [offset u32])
+(struct wire-error [error error] [offset u32])
 
-(struct wire-reader [bytes (slice u8)] [at u32] [error wire-error])
+(struct wire-reader [bytes (slice u8)] [at u32] [message string] [offset u32])
 
 ;; ---- writing ----
 
@@ -28,12 +28,12 @@
 (define (start! [r (ptr wire-reader)] [bytes (slice u8)])
   (set! (-> r bytes) bytes)
   (set! (-> r at) 0)
-  (set! (-> r error message) "")
-  (set! (-> r error offset) 0))
+  (set! (-> r message) "")
+  (set! (-> r offset) 0))
 
 (define (fail! [r (ptr wire-reader)] [message string]) -> bool
-  (set! (-> r error message) message)
-  (set! (-> r error offset) (-> r at))
+  (set! (-> r message) message)
+  (set! (-> r offset) (-> r at))
   #f)
 
 (define (refuse! [r (ptr wire-reader)] [at u32] [message string]) -> bool
@@ -45,7 +45,9 @@
 (define (end! [r (ptr wire-reader)]) -> bool (or (== (left r) 0) (fail! r "bytes follow the message")))
 
 (define (read-failed [r (ptr wire-reader)] [err (ptr wire-error)]) -> bool
-  (when (!= err 0) (set! (@ err) (-> r error)))
+  (unless (== err 0)
+    (error-fail! (& (-> err error)) error-invalid (-> r message))
+    (set! (-> err offset) (-> r offset)))
   #f)
 
 (define (take-byte! [r (ptr wire-reader)] [to (ptr u8)]) -> bool

package/std/http/form.sub

@@ -10,11 +10,11 @@
 
 (struct http-upload [filename string] [type string] [bytes (slice u8)])
 
-(struct form-error [message string] [field string])
+(struct form-error [error error] [field string])
 
 (define (refuse! [err (ptr form-error)] [message string] [field string]) -> bool
   (unless (== err 0)
-    (set! (-> err message) message)
+    (error-fail! (& (-> err error)) error-invalid message)
     (set! (-> err field) field))
   #f)
 

package/std/http/multipart.sub

@@ -11,9 +11,7 @@
 (define (multipart-boundary [a (ptr arena)] [content-type string]) -> string
   (if (http-media-type? content-type "multipart/form-data") (http-media-parameter a content-type "boundary") ""))
 
-(define (refused [why (ptr string)] [message string]) -> bool
-  (set! (@ why) message)
-  #f)
+(define (refused [err (ptr error)] [message string]) -> bool (error-fail! err error-invalid message))
 
 (define (at? [body (slice u8)] [i u32] [s string]) -> bool
   (and (<= (+ i (-> s length)) (-> body length)) (== (cast string (slice body i (+ i (-> s length)))) s)))
@@ -66,28 +64,28 @@
                     [(http-same? name "content-type") (set! (-> part type) (http-trimmed value))])))
           (set! start (+ i 1)))))))
 
-;; A body's named parts, in the arena; #f with the reason in why when the body is malformed.
+;; A body's named parts, in the arena.
 (define (multipart-parse [a (ptr arena)] [body (slice u8)] [boundary string] [to (ptr (slice multipart-part))]
-                         [why (ptr string)]) -> bool
+                         [err (ptr error)]) -> bool
   (set! (@ to) 0)
   (when (or (== (-> boundary length) 0) (> (-> boundary length) 70))
-    (return (refused why "the boundary is missing or longer than 70 bytes")))
+    (return (refused err "the boundary is missing or longer than 70 bytes")))
   (let* ([dash (joined a "--" boundary)] [delimiter (joined a "\r\n" dash)] [n (-> body length)]
          [first (if (at? body 0 dash) 0 (find body delimiter 0))]
          [at u32 0] [items (ptr multipart-part) 0] [count u32 0] [room u32 0])
-    (when (< first 0) (return (refused why "the body has no boundary")))
+    (when (< first 0) (return (refused err "the body has no boundary")))
     (set! at (+ (cast u32 first) (if (at? body 0 dash) 0 2) (-> dash length)))
     (while #t
       (when (at? body at "--") (break))
       (while (and (< at n) (or (== (@ body at) 32) (== (@ body at) 9))) (+= at 1))
-      (unless (at? body at "\r\n") (return (refused why "a boundary's line goes on past it")))
+      (unless (at? body at "\r\n") (return (refused err "a boundary's line goes on past it")))
       (+= at 2)
       (let* ([empty (at? body at "\r\n")] [end (if empty (cast i64 at) (find body "\r\n\r\n" at))]
              [part multipart-part] [start u32 0] [next i64 0])
-        (when (< end 0) (return (refused why "a part's head does not end")))
+        (when (< end 0) (return (refused err "a part's head does not end")))
         (set! start (+ (cast u32 end) (if empty 2 4)))
         (set! next (find body delimiter start))
-        (when (< next 0) (return (refused why "the body ends inside a part")))
+        (when (< next 0) (return (refused err "the body ends inside a part")))
         (set! (-> part name) "")
         (set! (-> part filename) "")
         (set! (-> part type) "")

package/std/http/route.sub

@@ -76,8 +76,9 @@
     (buffer-add-string! (& b) "field ")
     (buffer-add-string! (& b) (-> err field))
     (buffer-add-string! (& b) ": ")
-    (buffer-add-string! (& b) (-> err message))
+    (buffer-add-string! (& b) (error-text (& (-> err error))))
     (http-answer-text! r 400 (buffer-string (& b)))
+    (error-free! (& (-> err error)))
     (buffer-free! (& b))))
 
 (define (route-json-refused! [r (ptr http-request)] [err (ptr json-error)])
@@ -87,8 +88,9 @@
     (buffer-add-byte! (& b) #\:)
     (write-digits (& b) (-> err column) 10)
     (buffer-add-string! (& b) ": ")
-    (buffer-add-string! (& b) (-> err message))
+    (buffer-add-string! (& b) (error-text (& (-> err error))))
     (http-answer-text! r 400 (buffer-string (& b)))
+    (error-free! (& (-> err error)))
     (buffer-free! (& b))))
 
 (define (route-typed? [r (ptr http-request)] [json bool]) -> bool
@@ -103,12 +105,15 @@
 
 (define (route-form-fields [r (ptr http-request)] [body (slice u8)] [pairs (ptr (slice url-pair))]
                            [parts (ptr (slice multipart-part))]) -> bool
-  (let* ([a (& (-> r arena))] [t (http-request-header r "content-type")] [why string])
+  (let* ([a (& (-> r arena))] [t (http-request-header r "content-type")] [why error])
     (set! (@ pairs) 0)
     (set! (@ parts) 0)
     (if (http-media-type? t "multipart/form-data")
         (or (multipart-parse a body (multipart-boundary a t) parts (& why))
-            (begin (http-answer-text! r 400 why) #f))
+            (begin
+              (http-answer-text! r 400 (error-text (& why)))
+              (error-free! (& why))
+              #f))
         (begin (set! (@ pairs) (url-form-parse a (cast string body))) #t))))
 
 (define (route-add-text! [b (ptr buffer)] [s string])

package/std/http/server.sub

@@ -3,7 +3,8 @@
 ;; in ms, the default at 0 and none below 0: idle-timeout 5 s (130 s behind proxies), head-timeout 60 s,
 ;; request-timeout 300 s, send-timeout 60 s; body-limit for http-read-body!, 1 MiB at 0; compress, a gzip level for
 ;; answers of a type that compresses, of 1 KB or more, and for event streams that ask; proxies, how many proxies' hops
-;; of X-Forwarded headers to believe; checks, run before handle. problem holds why listening failed.
+;; of X-Forwarded headers to believe; checks, run before handle. problem holds the failure when listening fails after
+;; http-serve! returns.
 ;; A request lasts until it is answered and its body has ended; on-done is called as it ends and must not trap. A trap
 ;; in a request's code answers 500, or ends the connection once the answer has begun, and goes to on-trap, the log, or
 ;; stderr.
@@ -65,7 +66,7 @@
 
 (struct http-server [head event-head] [listener u32] [port u32] [host string] [secure bool] [most u32]
   [idle-timeout f64] [head-timeout f64] [request-timeout f64] [send-timeout f64] [body-limit u32] [compress i32]
-  [proxies u32] [checks (slice http-check)] [problem string] [user (ptr void)] [connections (ptr http-connection)]
+  [proxies u32] [checks (slice http-check)] [problem error] [user (ptr void)] [connections (ptr http-connection)]
   [hooks (ptr http-hook)] [stopping bool] [stop-timer u32] [stopped (fn ((ptr http-server)))] [log (ptr logger)]
   [handle (fn ((ptr http-request)))] [listening (fn ((ptr http-server)))] [on-trap (fn ((ptr http-request) string))]
   [on-done (fn ((ptr http-request)))])
@@ -977,19 +978,21 @@
            (when (!= (-> s listening) 0) ((-> s listening) s))]
           [(== kind net-accept) (if (-> s stopping) (stream-close (cast u32 value)) (accept! s (cast u32 value)))]
           [(== kind net-failed)
-           (set! (-> s port) 0)
-           (set! (-> s problem) (events-take-text))
-           (when (!= (-> s listening) 0) ((-> s listening) s))])))
+           (let ([why (events-take-text)])
+             (set! (-> s port) 0)
+             (error-fail! (& (-> s problem)) value why)
+             (free (-> why bytes))
+             (when (!= (-> s listening) 0) ((-> s listening) s)))])))
 
-(define (http-serve! [s (ptr http-server)] [port u32] [handle (fn ((ptr http-request)))]) -> u32
+(define (http-serve! [s (ptr http-server)] [port u32] [handle (fn ((ptr http-request)))] [err (ptr error)]) -> bool
   (trap-handler! http-trapped)
   (set! (-> s head handle) server-heard)
   (set! (-> s handle) handle)
   (set! (-> s connections) 0)
   (set! (-> s port) 0)
-  (set! (-> s problem) "")
-  (set! (-> s listener) (net-listen port (-> s host) (-> s secure) (-> s most) (cast (ptr void) s) (& (-> s problem))))
-  (-> s listener))
+  (error-free! (& (-> s problem)))
+  (set! (-> s problem code) 0)
+  (net-listen port (-> s host) (-> s secure) (-> s most) (cast (ptr void) s) (& (-> s listener)) err))
 
 ;; http-server-close! stops listening and drops every connection at once, and runs the hooks forced.
 (define (http-server-close! [s (ptr http-server)])
@@ -1084,8 +1087,8 @@
   (set! (-> stopper server) s)
   (set! (-> stopper ms) ms)
   (set! (-> stopper done) done)
-  (set! (-> stopper term) (signal-listen "SIGTERM" (cast (ptr void) (& stopper)) 0))
-  (signal-listen "SIGINT" (cast (ptr void) (& stopper)) 0))
+  (signal-listen "SIGTERM" (cast (ptr void) (& stopper)) (& (-> stopper term)) 0)
+  (signal-listen "SIGINT" (cast (ptr void) (& stopper)) 0 0))
 
 ;; ---- connections without streams ----
 

package/std/http/session.sub

@@ -97,9 +97,9 @@
       (raise-syntax-error 'session "this type needs a json form, which (json T) defines: write it first" t))
     `(,#`(define (#,(derive-name t '"session-read") [s (ptr http-sessions)] [r (ptr http-request)] [v (ptr #,t)])
            -> bool
-           (let ([bytes (slice u8)] [e json-error])
+           (let ([bytes (slice u8)])
              (and (http-session-read s r (& bytes))
-                  (#,(derive-name t '"json-read") (& (-> r arena)) (cast string bytes) v (& e)))))
+                  (#,(derive-name t '"json-read") (& (-> r arena)) (cast string bytes) v 0))))
       ,#`(define (#,(derive-name t '"session-write!") [s (ptr http-sessions)] [r (ptr http-request)] [v (ptr #,t)])
            (let ([b (make-buffer)])
              (#,(derive-name t '"json-write!") (& b) v)

package/std/http/static.sub

@@ -200,15 +200,15 @@
            (http-finish! r)]
           [(<= size whole)
            (let ([f (slice u8)])
-             (if (< (fs-read-file name (& f) 0) 0)
+             (if (not (fs-read-file name (& f) 0))
                  (failed! r)
                  (begin
                    (head-of! r name partial s size)
                    (http-send! r (slice f (cast u32 (-> s start)) (cast u32 (-> s end))))
                    (free (-> f items)))))]
           [else
-           (let* ([h (fs-open-file name fs-read-flag 0)] [file (if (== h 0) 0 (fs-read-stream h (-> s start) 0 0))])
-             (if (== file 0)
+           (let ([h u32 0] [file u32 0])
+             (if (not (and (fs-open-file name fs-read-flag (& h) 0) (fs-read-stream h (-> s start) 0 (& file) 0)))
                  (failed! r)
                  (begin
                    (head-of! r name partial s size)
@@ -262,7 +262,7 @@
         (if (and ok (> n 0) (== (refusal (slice parts n)) 0))
             (begin
               (joined! (& name) (slice parts n))
-              (if (and (>= (fs-stat (buffer-string (& name)) (& info) 0) 0) (== (-> info kind) fs-file))
+              (if (and (fs-stat (buffer-string (& name)) (& info) 0) (== (-> info kind) fs-file))
                   (send! r files (buffer-string (& name)) (slice (buffer-string (& name)) (+ prefix 1)) (& info))
                   (not-found! r)))
             (not-found! r))))
@@ -282,7 +282,7 @@
                        (joined! (& name) parts)
                        (when (== (-> parts length) 0) (buffer-add-byte! (& name) #\/))
                        (when slash (buffer-add-string! (& name) "index.html"))
-                       (let ([found (>= (fs-stat (buffer-string (& name)) (& info) 0) 0)])
+                       (let ([found (fs-stat (buffer-string (& name)) (& info) 0)])
                          (cond [(and found (== (-> info kind) fs-directory) (not slash)) (moved! r)]
                                [(or (not found) (!= (-> info kind) fs-file)) (not-found! r)]
                                [else

package/std/meta/derive.sub

@@ -21,7 +21,6 @@
        (while (< i (length wanted))
          (let* ([u (list-ref wanted i)] [info (type-info u)])
            (when (or (== info 0) (== (car info) 'union)) (raise-syntax-error who "expected a struct or variant type" u))
-           (unless (null? (cadddr info)) (raise-syntax-error who "expected a type without parameters" u))
            (set! out (append out (code u info))))
          (+= i 1))
        #`(begin #,@out))]
@@ -44,7 +43,6 @@
 (define (type-syntax [type datum]) -> datum
   (cond [(symbol? type) (datum->syntax #'here type 0)]
         [(identifier? type) type]
-        [(identifier? (car type)) #`(#,(car type) #,@(for/list ([u (cdr type)]) (type-syntax u)))]
         [(== (car type) 'array) #`(array #,(type-syntax (cadr type)) #,(datum->syntax #'here (caddr type) 0))]
         [(== (car type) 'other) (cadr type)]
         [else #`(#,(datum->syntax #'here (car type) 0) #,(type-syntax (cadr type)))]))

package/std/meta/method.sub

@@ -0,0 +1,41 @@
+;; Operations that pick their function by the type of their first argument, as method calls do. (method form suffix x
+;; arg ...) calls the function whose name is x's type followed by the suffix, for x a pointer to a named type. With
+;; suffix -push! and x a (ptr points), it calls points-push!. form is the operation's own form, for errors.
+;; (define-methods [operation suffix] ...) defines each operation as a macro that calls method with its suffix.
+;; method-name in std/meta/type-info gives the function's name, for macros that define the functions.
+(provide method define-methods)
+
+(begin-for-syntax
+  (require-unqualified compiler/macros)
+  (require-unqualified "type-info.sub")
+
+  (define (method-form [s datum]) -> datum
+    (syntax-match s
+      [(_ form suffix x arg ...) #`(let ([the-receiver #,x]) (method-call #,form #,suffix the-receiver #,@arg))]))
+
+  (define (method-call-form [s datum]) -> datum
+    (syntax-match s
+      [(_ form suffix x arg ...)
+       (let ([t (variable-type x)] [op (syntax-e (car (syntax->list form)))])
+         (unless (and (pair? t) (== (car t) 'ptr) (identifier? (cadr t)))
+           (raise-syntax-error op (datum->string (format "expected a pointer to a named type, not ~s" `(,(type-datum t))))
+                               form))
+         (let* ([name (method-name (cadr t) (syntax-e suffix))] [f (datum->syntax name (syntax-e name) form)])
+           (when (== (identifier-binding-kind f) '#f)
+             (raise-syntax-error op (format-message "~a has no ~a" `(,(syntax-e (cadr t)) ,(syntax-e f))) form))
+           #`(#,f #,x #,@arg)))]))
+
+  (define (operation-form [suffix datum] [s datum]) -> datum
+    (syntax-match s
+      [(_ x arg ...) #`(method #,s #,(datum->syntax s suffix s) #,x #,@arg)]
+      [_ (raise-syntax-error 0 "expected a pointer to a named type" s)]))
+
+  (define (define-methods-form [s datum]) -> datum
+    (syntax-match s
+      [(_ ((? identifier? op) (? identifier? suffix)) ...)
+       #`(begin #,@(for/list ([o op] [x suffix]) #`(define-syntax #,o operation-form '#,x)))]
+      [_ (raise-syntax-error 'define-methods "expected (define-methods [operation suffix] ...)" s)])))
+
+(define-syntax method method-form)
+(define-syntax method-call method-call-form)
+(define-syntax define-methods define-methods-form)

package/std/meta/type-info.sub

@@ -1,54 +1,44 @@
 ;; Types as data at compile time, for macros that write code from a type's fields.
 (require-unqualified compiler/macros)
 
-(provide type-info variable-type type-datum)
+(provide type-info variable-type type-datum method-name)
 
-;; (kind name items parameters), kind struct, union, variant or enum, or 0 when t names none. A struct's or union's items
-;; are (field . type), a variant's (case (field . type) ...) and an enum's (case). A type is i8 to u64, f32, f64, bool or
-;; string, (ptr type), (slice type), (array type n), a struct's, union's, variant's or enum's identifier,
-;; (identifier type ...) for one with parameters, or (other type). For (identifier type ...), the items have those types
-;; in place of the parameters, and the parameters are ().
+;; (kind name items), kind struct, union, variant or enum, or 0 when t names none. A struct's or union's items are
+;; (field . type), a variant's (case (field . type) ...) and an enum's (case). A type is i8 to u64, f32, f64, bool or
+;; string, (ptr type), (slice type), (array type n), a struct's, union's, variant's or enum's identifier, or
+;; (other type).
 (define (type-info [t datum]) -> datum
-  (let ([instance (pair? t)])
-    (syntax-match (binding-of (if instance (car t) t))
-      [('substrate-struct name (item ...) kind (p ...) . _)
-       (let ([k (syntax-e kind)] [env (if instance (for/list ([q p] [a (cdr t)]) (cons (syntax-e q) a)) nil)])
-         `(,k ,name ,(for/list ([i item]) (if (!= (memq k '(variant enum)) 0) (case-info i env) (field-info i env)))
-           ,(if instance nil p)))]
-      [('substrate-typedef u)
-       (let ([d (parsed-type (syntax->datum u))])
-         (if (or (identifier? d) (and (pair? d) (identifier? (car d)))) (type-info d) 0))]
-      [_ 0])))
+  (syntax-match (binding-of t)
+    [('substrate-struct name (item ...) kind . _)
+     (let ([k (syntax-e kind)])
+       `(,k ,name ,(for/list ([i item]) (if (!= (memq k '(variant enum)) 0) (case-info i) (field-info i)))))]
+    [('substrate-typedef u) (let ([d (parsed-type (syntax->datum u))]) (if (identifier? d) (type-info d) 0))]
+    [_ 0]))
 
 (define (binding-of [t datum]) -> datum
   (if (and (identifier? t) (== (identifier-binding-kind t) 'compile-time-value)) (syntax-local-value t) 0))
 
-(define (case-info [c datum] [env datum]) -> datum
-  (let ([l (syntax->list c)]) (cons (car l) (for/list ([f (cdr l)]) (field-info f env)))))
+(define (case-info [c datum]) -> datum
+  (let ([l (syntax->list c)]) (cons (car l) (for/list ([f (cdr l)]) (field-info f)))))
 
-(define (field-info [f datum] [env datum]) -> datum
-  (let ([l (syntax->list f)]) (cons (car l) (type-of (cadr l) env))))
+(define (field-info [f datum]) -> datum
+  (let ([l (syntax->list f)]) (cons (car l) (type-of (cadr l)))))
 
 (define scalars datum '(i8 u8 i16 u16 i32 u32 i64 u64 f32 f64 bool string))
 
-(define (type-of [t datum] [env datum]) -> datum
+(define (type-of [t datum]) -> datum
   (syntax-match t
     [(? identifier? x)
-     (cond [(!= (memq (syntax-e x) scalars) 0) (syntax-e x)]
-           [(!= (assq (syntax-e x) env) 0) (cdr (assq (syntax-e x) env))]
-           [else (syntax-match (binding-of x)
-                   [('substrate-struct _ _ _ () . _) x]
-                   [('substrate-typedef u) (parsed-type (syntax->datum u))]
-                   [_ `(other ,t)])])]
-    [('ptr u) `(ptr ,(type-of u env))]
-    [('slice u) `(slice ,(type-of u env))]
-    [('array u n) `(array ,(type-of u env) ,(syntax-e n))]
+     (if (!= (memq (syntax-e x) scalars) 0)
+         (syntax-e x)
+         (syntax-match (binding-of x)
+           [('substrate-struct . _) x]
+           [('substrate-typedef u) (parsed-type (syntax->datum u))]
+           [_ `(other ,t)]))]
+    [('ptr u) `(ptr ,(type-of u))]
+    [('slice u) `(slice ,(type-of u))]
+    [('array u n) `(array ,(type-of u) ,(syntax-e n))]
     [('quote u) (parsed-type (syntax->datum u))]
-    [((? identifier? h) a ...)
-     (syntax-match (binding-of h)
-       [('substrate-struct _ _ _ (p ...) . _)
-        (if (and (pair? p) (== (length p) (length a))) `(,h ,@(for/list ([u a]) (type-of u env))) `(other ,t))]
-       [_ `(other ,t)])]
     [_ `(other ,t)]))
 
 (define (variable-type [x datum]) -> datum
@@ -57,11 +47,14 @@
 (define (type-datum [t datum]) -> datum
   (let ([d (syntax->datum (datum->syntax #'here t 0))]) (if (and (pair? d) (== (car d) 'other)) (cadr d) d)))
 
+;; The function std/meta/method calls for type t and a suffix: points-push! for points and -push!.
+(define (method-name [t datum] [suffix datum]) -> datum
+  (datum->syntax t (string->symbol (format-message "~a~a" `(,(syntax-e t) ,suffix))) t))
+
 ;; A type as the checker holds it.
 (define (parsed-type [d datum]) -> datum
   (cond [(and (symbol? d) (!= (memq d scalars) 0)) d]
         [(and (pair? d) (!= (memq (car d) '(ptr slice)) 0)) `(,(car d) ,(parsed-type (cadr d)))]
         [(and (pair? d) (== (car d) 'array)) `(array ,(parsed-type (cadr d)) ,(caddr d))]
-        [(and (pair? d) (memq (car d) '(struct enum)) (null? (cdddr d))) (name-identifier (cadr d))]
-        [(and (pair? d) (== (car d) 'struct)) `(,(name-identifier (cadr d)) ,@(for/list ([a (cadddr d)]) (parsed-type a)))]
+        [(and (pair? d) (!= (memq (car d) '(struct enum)) 0)) (name-identifier (cadr d))]
         [else `(other ,d)]))

package/std/package/files.sub

@@ -19,17 +19,17 @@
 ;; tracked-files adds the files package-tree finds. When a git repository tracks dir's marker file, it adds only the files
 ;; git tracks. It gives #f when it cannot read git's index.
 (define (tracked-files [a (ptr arena)] [dir string] [marker string] [files (ptr buffer)] [err (ptr buffer)]) -> bool
-  (let ([all (make-buffer)] [nested (make-buffer)] [tracked (make-buffer)] [got i32 0])
+  (let ([all (make-buffer)] [nested (make-buffer)] [tracked (make-buffer)] [marked #f] [ok #f])
     (package-tree a dir (& all) (& nested))
-    (set! got (git-tracked a dir marker (& tracked) err))
+    (set! ok (git-tracked a dir marker (& tracked) (& marked) err))
     (let ([ps (cast (ptr string) (-> all bytes))] [ts (cast (ptr string) (-> tracked bytes))]
           [t (/ (-> tracked length) (sizeof string))])
-      (for ([i u32 0]) (and (>= got 0) (< i (/ (-> all length) (sizeof string)))) (+= i 1)
-        (when (or (== got 0) (listed? ts t (@ ps i))) (added! files (@ ps i)))))
+      (for ([i u32 0]) (and ok (< i (/ (-> all length) (sizeof string)))) (+= i 1)
+        (when (or (not marked) (listed? ts t (@ ps i))) (added! files (@ ps i)))))
     (buffer-free! (& all))
     (buffer-free! (& nested))
     (buffer-free! (& tracked))
-    (>= got 0)))
+    ok))
 
 (define (listed? [ts (ptr string)] [n u32] [p string]) -> bool
   (let ([lo u32 0] [hi n])
@@ -46,25 +46,24 @@
   (tree! a dir "" files nested))
 
 (define (tree! [a (ptr arena)] [dir string] [rel string] [files (ptr buffer)] [nested (ptr buffer)])
-  (let ([here (if (== (-> rel length) 0) dir (joined-path dir rel))] [names (slice string)] [why string])
-    (if (< (fs-list here (& names) (& why)) 0)
-        (free (-> why bytes))
-        (for ([i u32 0]) (< i (-> names length)) (+= i 1)
-          (let* ([n (@ names i)] [r (if (== (-> rel length) 0) (kept a n) (kept-joined a rel n))] [full (joined-path dir r)]
-                 [info fs-info])
-            (when (and (not (and (== (-> rel length) 0) (== n "build"))) (!= n ".git") (== (fs-lstat full (& info) 0) 0))
-              (cond [(== (-> info kind) fs-file) (when (!= files 0) (added! files r))]
-                    [(== (-> info kind) fs-directory)
-                     (let ([own (joined-path full "package.sub")] [m manifest] [err (make-buffer)] [p nested-package])
-                       (if (and (== (fs-stat own (& info) 0) 0) (== (-> info kind) fs-file))
-                           (begin
-                             (set! (-> p name) (if (manifest-read a own (& m) (& err)) (-> m name) (kept a n)))
-                             (set! (-> p path) r)
-                             (buffer-add! nested (slice (cast (ptr u8) (& p)) (sizeof nested-package))))
-                           (tree! a dir r files nested))
-                       (buffer-free! (& err))
-                       (free (-> own bytes)))]))
-            (free (-> full bytes)))))
+  (let ([here (if (== (-> rel length) 0) dir (joined-path dir rel))] [names (slice string)])
+    (when (fs-list here (& names) 0)
+      (for ([i u32 0]) (< i (-> names length)) (+= i 1)
+        (let* ([n (@ names i)] [r (if (== (-> rel length) 0) (kept a n) (kept-joined a rel n))] [full (joined-path dir r)]
+               [info fs-info])
+          (when (and (not (and (== (-> rel length) 0) (== n "build"))) (!= n ".git") (fs-lstat full (& info) 0))
+            (cond [(== (-> info kind) fs-file) (when (!= files 0) (added! files r))]
+                  [(== (-> info kind) fs-directory)
+                   (let ([own (joined-path full "package.sub")] [m manifest] [err (make-buffer)] [p nested-package])
+                     (if (and (fs-stat own (& info) 0) (== (-> info kind) fs-file))
+                         (begin
+                           (set! (-> p name) (if (manifest-read a own (& m) (& err)) (-> m name) (kept a n)))
+                           (set! (-> p path) r)
+                           (buffer-add! nested (slice (cast (ptr u8) (& p)) (sizeof nested-package))))
+                         (tree! a dir r files nested))
+                     (buffer-free! (& err))
+                     (free (-> own bytes)))]))
+          (free (-> full bytes)))))
     (unless (== (-> rel length) 0) (free (-> here bytes)))))
 
 (define (package-exports [a (ptr arena)] [dir string] [m (ptr manifest)] [exports (ptr buffer)] [err (ptr buffer)]) -> bool
@@ -88,7 +87,7 @@
 
 (define (file-in? [dir string] [p string]) -> bool
   (let ([full (joined-path dir p)] [info fs-info] [found #f])
-    (set! found (and (== (fs-stat full (& info) 0) 0) (== (-> info kind) fs-file)))
+    (set! found (and (fs-stat full (& info) 0) (== (-> info kind) fs-file)))
     (free (-> full bytes))
     found))