Merge branch 'develop'

owl/codec.scm

@@ -5,8 +5,10 @@
      (owl proof))
 
   (export 
-    hex-encode     ;; str → str
-    hex-decode)    ;; str → str | #false
+    hex-encode-list  ;; (byte ...) → str
+    hex-encode       ;; str → str
+    hex-decode       ;; str → str | #false
+    hex-decode-list) ;; str → (byte ...) | #false
 
   (begin
 
@@ -51,16 +53,20 @@
                               #false))))
                   (else #false))))))
 
-   (define (hex-encode str)
+   (define (hex-encode-list lst)
       (list->string
-         (hex-encode-bytes
-            (string->bytes str))))
+         (hex-encode-bytes lst)))
+
+   (define (hex-encode str)
+      (hex-encode-list 
+         (string->bytes str)))
 
+   (define (hex-decode-list str)
+      (hex-decode-bytes (string->bytes str)))
+
    (define (hex-decode str)
-      (let ((bs (hex-decode-bytes (string->bytes str))))
-         (if bs
-            (bytes->string bs)
-            #false)))
+      (maybe bytes->string
+         (hex-decode-list str)))
 
    (example
       (hex-decode (hex-encode "")) = ""

owl/date.scm

@@ -14,11 +14,14 @@
       leap-year?  ;; y → bool
       valid-date? ;; d m y → bool
       next-date   ;; d m y → d' m' y'
+      next-date-with-week   ;; d m y wd wn → d' m' y' wd' wn'
       week-info   ;; d m y → week weekday
       day-names-fi
       day-names-en
       date-str    ;; secs [tz-offset-hours] -> str
       date-str-tz ;; secs tz-offset-hours -> str
+      year-start-day
+      year-start-week-info
       minute hour day week year leap-year)
 
    (begin
@@ -65,6 +68,7 @@
                   (values 1 (+ month 1) year)))
             (else
                (values (+ day 1) month year))))
+
 
       ;; date is valid *and* date computations work for it
       (define (valid-date? d m y)
@@ -136,7 +140,7 @@
               ;; whole week fits the year
               (values week day))
             ((< (+ md (days-to-thursday day)) 32)
-              ;; partial, but switch happens before thursday
+              ;; partial week, but switch happens before thursday
               (values week day))
             (else
               ;; subsequent thursday falls to next year
@@ -157,6 +161,19 @@
                         (loop rd rm (+ week 1) day reset?))
                       (loop rd rm week day reset?)))))))
 
+      (define (next-date-with-week day month year week-day week-num)
+         (lets ((d m y (next-date day month year)))
+            (if (eq? week-day 7)
+               (if (< week-num 52)
+                  (values d m y 1 (+ week-num 1))
+                  (lets ((wn wd (week-info d m y)))
+                     (values d m y wd wn)))
+               (values d m y (+ week-day 1) week-num))))
+
+      (example
+         (next-date-with-week 31 12 1971 5 1) = (values 1 1 1972 6 1)
+         (next-date-with-week 27 12 1970 7 52) = (values 28 12 1970 1 53))
+
       ;;;
       ;;; UNIXish time
       ;;;

owl/defmac.scm

@@ -58,6 +58,7 @@
       ;; k v r, k v l r+    -- type-ff-right
       ;; k v l, k v l+ r    -- type-ff-leftc
 
+      maybe
    )
 
    (begin
@@ -569,4 +570,7 @@
              ((if-lets bindings then)
                (if-lets bindings then #false))))
 
+      (define (maybe op arg)
+         (if arg (op arg) arg))
+
 ))

owl/digest.scm

@@ -217,11 +217,21 @@
                (cons (bxor a b)
                   (list-xor as bs))))))
 
+   (define (any->bytes x)
+      (cond
+         ((string? x)
+            (string->bytes x))
+         ((vector? x)
+            (vector->list x))
+         (else
+            ;; may be a lazy list or list
+            x)))
+
    (define (make-hmac hasher blocksize)
       (lambda (key msg)
          (lets
-            ((key (string->bytes key)) ;; we want to UTF-8 encode it
-             (msg (string->bytes msg)) ;; ditto
+            ((key (any->bytes key)) ;; we want to UTF-8 encode it
+             (msg (any->bytes msg)) ;; ditto
              (key (if (> (length key) blocksize) (hasher key) key))
              (key
                (append key

owl/dump.scm

@@ -333,7 +333,9 @@
       ; dump entry object to path, or stdout if path is "-"
 
       (define (make-compiler extras)
-         (λ (entry path opts native) ; <- this is the usual compile-owl 
+         (λ (entry path opts native . custom-runtime) ; <- this is the usual compile-owl 
+            (if (null? custom-runtime)
+               (print-to stderr "custom runtime not provided"))
             (lets
                ((path (get opts 'output "-")) ; <- path argument deprecated
                 (format 
@@ -383,7 +385,12 @@
 
                 (bytes ;; encode the resulting object for saving in some form
                   (fasl-encode-cooked entry native-cook))
-
+
+                (runtime
+                   (if (and (pair? custom-runtime) (car custom-runtime))
+                      (car custom-runtime)
+                      rts-source))
+
                 (port ;; where to save the result
                   (if (equal? path "-")
                      stdout
@@ -410,7 +417,7 @@
                      ;; dump ovm.c and replace /* AUTOGENERATED INSTRUCTIONS */ with new native ops (if any)
                      (write-bytes port 
                         (string->bytes 
-                           (str-replace rts-source
+                           (str-replace runtime
                               "/* AUTOGENERATED INSTRUCTIONS */"
                               (render-native-ops native-ops))))
 

owl/env.scm

@@ -231,10 +231,12 @@
                      or return arity error where first is function))
                 (else
                    `(wrong number of returned values ,(tuple->list b))))))
+          ((eq? opcode 0)
+             `("error: bad call: operator " ,a ", args w/ cont " ,b))
           ((eq? opcode 52)
-            `(trying to get car of a non-pair ,a))
+            `("error: car on non-pair " ,a))
           ((eq? opcode 53)
-            `(trying to get cdr of a non-pair ,a))
+            `("error: cdr on non-pair " ,a))
           (else
             `("error: instruction" ,(primop-name opcode) "reported error: " ,a " " ,b))))
 

owl/io.scm

@@ -31,6 +31,7 @@
 
       file->vector            ;; vector io, may be moved elsewhere later
       file->list              ;; list io, may be moved elsewhere later
+      file->byte-stream       ;; path → #false | (byte ...)
       vector->file
       write-vector            ;; vec port
       port->meta-byte-stream  ;; fd → (byte|'io-error|'block ...) | thunk 

owl/lazy.scm

@@ -10,7 +10,7 @@
    (export 
       lfold lfoldr lmap lappend    ; main usage patterns
       lfor liota liter lnums
-      lzip ltake llast llen
+      lzip ltake lsplit llast llen
       lcar lcdr
       lkeep lremove
       ldrop llref ledit
@@ -27,9 +27,11 @@
       (owl defmac)
       (owl list)
       (owl list-extra)
+      (owl proof)
       (only (owl syscall) error))
 
    (begin
+
       ;; convert an application to a thunk
       (define-syntax delay
          (syntax-rules ()
@@ -61,7 +63,7 @@
                   (if (null? tl) (car l) (llast tl))))
             ((null? l) (error "llast: empty list: " l))
             (else (llast (l)))))
-
+         
       ;; l → hd l' | error
       (define (uncons l d)
          (cond
@@ -218,6 +220,21 @@
             (else
                (λ () (ltake (l) n)))))
 
+      (define (lsplit l n) 
+         (let loop ((l l) (o null) (n n))
+            (cond
+               ((eq? n 0) 
+                  (values (reverse o) l))
+               ((pair? l)
+                  (loop (cdr l) (cons (car l) o) (- n 1)))
+               ((null? l)
+                  (loop l o 0))
+               (else
+                  (loop (l) o n)))))
+
+      (example 
+         (lsplit '(1 2 3 4) 2) = (values '(1 2) '(3 4)))
+
       (define (lkeep p l) 
          (cond
             ((null? l) l)

owl/list-extra.scm

@@ -13,10 +13,12 @@
    (import
       (owl math)
       (owl list)
+      (owl proof)
       (owl defmac)
       (owl syscall))
 
    (begin
+
       (define (lref lst pos)
          (cond
             ((null? lst) (error "lref: out of list" pos))
@@ -47,7 +49,7 @@
             (else
                (lets ((hd tl lst))
                   (cons hd (ledn tl (- pos 1) op))))))
-         
+
       ;; list edit - apply op to value at given pos
       (define (led lst pos op)
          (cond
@@ -56,7 +58,7 @@
             (else
                (lets ((hd tl lst))
                   (cons hd (led tl (- pos 1) op))))))
-
+      
       ;; insert value to list at given position
       (define (lins lst pos val)
          (cond
@@ -66,27 +68,38 @@
                (lets ((hd tl lst))
                   (cons hd (lins tl (- pos 1) val))))))
 
+      (example         
+         (lref '(a b c) 1) = 'b
+         (lset '(a b c) 1 'x) = '(a x c)
+         (ldel '(a b c) 1)  = '(a c)
+         (led '(1 2 3) 1 (λ (x) (* x 10))) =  '(1 20 3)
+         (ledn '(1 2 3) 1 (λ (lst) (cons 'x lst))) = '(1 x 2 3)
+         (lins '(a b c) 1 'x) = '(a x b c))
+
       (define (length lst)
          (fold (λ (n v) (+ n 1)) 0 lst))
 
       ; take at n (or less) elemts from list l
 
       (define (take l n)
-         (cond	
+         (cond
             ((eq? n 0) null)
             ((null? l) null)
             (else (cons (car l) (take (cdr l) (- n 1))))))
 
-      ; drop n elements (or less) from list l
-
       (define (drop l n)
          (cond
             ((eq? n 0) l)
             ((null? l) l)
             (else (drop (cdr l) (- n 1)))))
 
-      ; fixme, iotas should be unfolds
-
+      (example
+         (length '(a b c)) = 3
+         (take '(a b c) 2) = '(a b)
+         (take '(a) 100) = '(a)
+         (drop '(a b c) 2) = '(c)
+         (drop '(a) 100) = '())
+
       (define (iota-up p s e)
          (if (< p e)
             (cons p (iota-up (+ p s) s e))
@@ -107,6 +120,10 @@
                null)
             (else 
                (error "bad iota: " (list 'iota from step to)))))
+
+      (example
+         (iota 0 1 5) = '(0 1 2 3 4)
+         (iota 10 -2 0) = '(10 8 6 4 2))
 
       (define (list-tail lst n)
          (if (eq? n 0)
@@ -129,4 +146,8 @@
                (else 
                   (loop (cdr l) (cons (car l) o) (- n 1))))))
 
+      (example
+         (list-tail '(a b c) 1) = '(b c)
+         (repeat 'x 3) = '(x x x)
+         (split '(a b c d) 2) = (values '(a b) '(c d)))
 ))

owl/list.scm

@@ -320,10 +320,6 @@
                   (list a)
                   (ilist a mid (loop (car as) (cdr as)))))))
 
-      (example
-         (interleave 'x '(a b c)) = '(a x b x c)
-         (interleave 'x '()) = ())
-
       ;; lst → a b, a ++ b == lst, length a = length b | length b + 1
       (define (halve lst)
          (let walk ((t lst) (h lst) (out null))
@@ -337,5 +333,11 @@
          (example 
             l = (lets ((head tail (halve l))) (append head tail))))
 
+      (example
+         (interleave 'x '(a b c)) = '(a x b x c)
+         (interleave 'x '()) = ()
+         (halve '(a b c d)) = (values '(a b) '(c d))
+         (halve '(a b c d e)) = (values '(a b c) '(d e)))
+
       (define ╯°□°╯ reverse)     
 ))