diff --git a/init.scm b/init.scm
index 106afd5..83261b0 100644
--- a/init.scm
+++ b/init.scm
@@ -1,796 +1,813 @@
; Initialization file for TinySCHEME 1.41
; Per R5RS, up to four deep compositions should be defined
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
;;;; Utility to ease macro creation
(define (macro-expand form)
((eval (get-closure-code (eval (car form)))) form))
(define (macro-expand-all form)
(if (macro? form)
(macro-expand-all (macro-expand form))
form))
(define *compile-hook* macro-expand-all)
(macro (unless form)
`(if (not ,(cadr form)) (begin ,@(cddr form))))
(macro (when form)
`(if ,(cadr form) (begin ,@(cddr form))))
; DEFINE-MACRO Contributed by Andy Gaynor
(macro (define-macro dform)
(if (symbol? (cadr dform))
`(macro ,@(cdr dform))
(let ((form (gensym)))
`(macro (,(caadr dform) ,form)
(apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
; Utilities for math. Notice that inexact->exact is primitive,
; but exact->inexact is not.
(define exact? integer?)
(define (inexact? x) (and (real? x) (not (integer? x))))
(define (even? n) (= (remainder n 2) 0))
(define (odd? n) (not (= (remainder n 2) 0)))
(define (zero? n) (= n 0))
(define (positive? n) (> n 0))
(define (negative? n) (< n 0))
(define complex? number?)
(define rational? real?)
(define (abs n) (if (>= n 0) n (- n)))
(define (exact->inexact n) (* n 1.0))
(define (<> n1 n2) (not (= n1 n2)))
; min and max must return inexact if any arg is inexact; use (+ n 0.0)
(define (max . lst)
(foldr (lambda (a b)
(if (> a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (min . lst)
(foldr (lambda (a b)
(if (< a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (succ x) (+ x 1))
(define (pred x) (- x 1))
(define gcd
(lambda a
(if (null? a)
0
(let ((aa (abs (car a)))
(bb (abs (cadr a))))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))))
(define lcm
(lambda a
(if (null? a)
1
(let ((aa (abs (car a)))
(bb (abs (cadr a))))
(if (or (= aa 0) (= bb 0))
0
(abs (* (quotient aa (gcd aa bb)) bb)))))))
(define (string . charlist)
(list->string charlist))
(define (list->string charlist)
(let* ((len (length charlist))
(newstr (make-string len))
(fill-string!
(lambda (str i len charlist)
(if (= i len)
str
(begin (string-set! str i (car charlist))
(fill-string! str (+ i 1) len (cdr charlist)))))))
(fill-string! newstr 0 len charlist)))
(define (string-fill! s e)
(let ((n (string-length s)))
(let loop ((i 0))
(if (= i n)
s
(begin (string-set! s i e) (loop (succ i)))))))
(define (string->list s)
(let loop ((n (pred (string-length s))) (l '()))
(if (= n -1)
l
(loop (pred n) (cons (string-ref s n) l)))))
(define (string-copy str)
(string-append str))
(define (string->anyatom str pred)
(let* ((a (string->atom str)))
(if (pred a) a
(error "string->xxx: not a xxx" a))))
(define (string->number str . base)
(let ((n (string->atom str (if (null? base) 10 (car base)))))
(if (number? n) n #f)))
(define (anyatom->string n pred)
(if (pred n)
(atom->string n)
(error "xxx->string: not a xxx" n)))
(define (number->string n . base)
(atom->string n (if (null? base) 10 (car base))))
(define (char-cmp? cmp a b)
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b)
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) (char-cmp? = a b))
(define (char? a b) (char-cmp? > a b))
(define (char<=? a b) (char-cmp? <= a b))
(define (char>=? a b) (char-cmp? >= a b))
(define (char-ci=? a b) (char-ci-cmp? = a b))
(define (char-ci? a b) (char-ci-cmp? > a b))
(define (char-ci<=? a b) (char-ci-cmp? <= a b))
(define (char-ci>=? a b) (char-ci-cmp? >= a b))
; Note the trick of returning (cmp x y)
(define (string-cmp? chcmp cmp a b)
(let ((na (string-length a)) (nb (string-length b)))
(let loop ((i 0))
(cond
((= i na)
(if (= i nb) (cmp 0 0) (cmp 0 1)))
((= i nb)
(cmp 1 0))
((chcmp = (string-ref a i) (string-ref b i))
(loop (succ i)))
(else
(chcmp cmp (string-ref a i) (string-ref b i)))))))
(define (string=? a b) (string-cmp? char-cmp? = a b))
(define (string? a b) (string-cmp? char-cmp? > a b))
(define (string<=? a b) (string-cmp? char-cmp? <= a b))
(define (string>=? a b) (string-cmp? char-cmp? >= a b))
(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b))
(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
(define (list . x) x)
(define (foldr f x lst)
(if (null? lst)
x
(foldr f (f x (car lst)) (cdr lst))))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (map proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
'()
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(cons (apply proc cars) (apply map (cons proc cdrs)))))))
(define (for-each proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))
(define (list-tail x k)
(if (zero? k)
x
(list-tail (cdr x) (- k 1))))
(define (list-ref x k)
(car (list-tail x k)))
(define (last-pair x)
(if (pair? (cdr x))
(last-pair (cdr x))
x))
(define (head stream) (car stream))
(define (tail stream) (force (cdr stream)))
(define (vector-equal? x y)
(and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
(let ((n (vector-length x)))
(let loop ((i 0))
(if (= i n)
#t
(and (equal? (vector-ref x i) (vector-ref y i))
(loop (succ i))))))))
(define (list->vector x)
(apply vector x))
(define (vector-fill! v e)
(let ((n (vector-length v)))
(let loop ((i 0))
(if (= i n)
v
(begin (vector-set! v i e) (loop (succ i)))))))
(define (vector->list v)
(let loop ((n (pred (vector-length v))) (l '()))
(if (= n -1)
l
(loop (pred n) (cons (vector-ref v n) l)))))
;; The following quasiquote macro is due to Eric S. Tiedemann.
;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
;;
;; Subsequently modified to handle vectors: D. Souflis
(macro
quasiquote
(lambda (l)
(define (mcons f l r)
(if (and (pair? r)
(eq? (car r) 'quote)
(eq? (car (cdr r)) (cdr f))
(pair? l)
(eq? (car l) 'quote)
(eq? (car (cdr l)) (car f)))
(if (or (procedure? f) (number? f) (string? f))
f
(list 'quote f))
(if (eqv? l vector)
(apply l (eval r))
(list 'cons l r)
)))
(define (mappend f l r)
(if (or (null? (cdr f))
(and (pair? r)
(eq? (car r) 'quote)
(eq? (car (cdr r)) '())))
l
(list 'append l r)))
(define (foo level form)
(cond ((not (pair? form))
(if (or (procedure? form) (number? form) (string? form))
form
(list 'quote form))
)
((eq? 'quasiquote (car form))
(mcons form ''quasiquote (foo (+ level 1) (cdr form))))
(#t (if (zero? level)
(cond ((eq? (car form) 'unquote) (car (cdr form)))
((eq? (car form) 'unquote-splicing)
(error "Unquote-splicing wasn't in a list:"
form))
((and (pair? (car form))
(eq? (car (car form)) 'unquote-splicing))
(mappend form (car (cdr (car form)))
(foo level (cdr form))))
(#t (mcons form (foo level (car form))
(foo level (cdr form)))))
(cond ((eq? (car form) 'unquote)
(mcons form ''unquote (foo (- level 1)
(cdr form))))
((eq? (car form) 'unquote-splicing)
(mcons form ''unquote-splicing
(foo (- level 1) (cdr form))))
(#t (mcons form (foo level (car form))
(foo level (cdr form)))))))))
(foo 0 (car (cdr l)))))
;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
(define (shared-tail x y)
(let ((len-x (length x))
(len-y (length y)))
(define (shared-tail-helper x y)
(if
(eq? x y)
x
(shared-tail-helper (cdr x) (cdr y))))
(cond
((> len-x len-y)
(shared-tail-helper
(list-tail x (- len-x len-y))
y))
((< len-x len-y)
(shared-tail-helper
x
(list-tail y (- len-y len-x))))
(#t (shared-tail-helper x y)))))
;;;;;Dynamic-wind by Tom Breton (Tehom)
;;Guarded because we must only eval this once, because doing so
;;redefines call/cc in terms of old call/cc
(unless (defined? 'dynamic-wind)
(let
;;These functions are defined in the context of a private list of
;;pairs of before/after procs.
( (*active-windings* '())
;;We'll define some functions into the larger environment, so
;;we need to know it.
(outer-env (current-environment)))
;;Poor-man's structure operations
(define before-func car)
(define after-func cdr)
(define make-winding cons)
;;Manage active windings
(define (activate-winding! new)
((before-func new))
(set! *active-windings* (cons new *active-windings*)))
(define (deactivate-top-winding!)
(let ((old-top (car *active-windings*)))
;;Remove it from the list first so it's not active during its
;;own exit.
(set! *active-windings* (cdr *active-windings*))
((after-func old-top))))
(define (set-active-windings! new-ws)
(unless (eq? new-ws *active-windings*)
(let ((shared (shared-tail new-ws *active-windings*)))
;;Define the looping functions.
;;Exit the old list. Do deeper ones last. Don't do
;;any shared ones.
(define (pop-many)
(unless (eq? *active-windings* shared)
(deactivate-top-winding!)
(pop-many)))
;;Enter the new list. Do deeper ones first so that the
;;deeper windings will already be active. Don't do any
;;shared ones.
(define (push-many new-ws)
(unless (eq? new-ws shared)
(push-many (cdr new-ws))
(activate-winding! (car new-ws))))
;;Do it.
(pop-many)
(push-many new-ws))))
;;The definitions themselves.
(eval
`(define call-with-current-continuation
;;It internally uses the built-in call/cc, so capture it.
,(let ((old-c/cc call-with-current-continuation))
(lambda (func)
;;Use old call/cc to get the continuation.
(old-c/cc
(lambda (continuation)
;;Call func with not the continuation itself
;;but a procedure that adjusts the active
;;windings to what they were when we made
;;this, and only then calls the
;;continuation.
(func
(let ((current-ws *active-windings*))
(lambda (x)
(set-active-windings! current-ws)
(continuation x)))))))))
outer-env)
;;We can't just say "define (dynamic-wind before thunk after)"
;;because the lambda it's defined to lives in this environment,
;;not in the global environment.
(eval
`(define dynamic-wind
,(lambda (before thunk after)
;;Make a new winding
(activate-winding! (make-winding before after))
(let ((result (thunk)))
;;Get rid of the new winding.
(deactivate-top-winding!)
;;The return value is that of thunk.
result)))
outer-env)))
(define call/cc call-with-current-continuation)
;;;;; atom? and equal? written by a.k
;;;; atom?
(define (atom? x)
(not (pair? x)))
;;;; equal?
(define (equal? x y)
(cond
((pair? x)
(and (pair? y)
(equal? (car x) (car y))
(equal? (cdr x) (cdr y))))
((vector? x)
(and (vector? y) (vector-equal? x y)))
((string? x)
(and (string? y) (string=? x y)))
(else (eqv? x y))))
;;;; (do ((var init inc) ...) (endtest result ...) body ...)
;;
(macro do
(lambda (do-macro)
(apply (lambda (do vars endtest . body)
(let ((do-loop (gensym)))
`(letrec ((,do-loop
(lambda ,(map (lambda (x)
(if (pair? x) (car x) x))
`,vars)
(if ,(car endtest)
(begin ,@(cdr endtest))
(begin
,@body
(,do-loop
,@(map (lambda (x)
(cond
((not (pair? x)) x)
((< (length x) 3) (car x))
(else (car (cdr (cdr x))))))
`,vars)))))))
(,do-loop
,@(map (lambda (x)
(if (and (pair? x) (cdr x))
(car (cdr x))
'()))
`,vars)))))
do-macro)))
;;;; generic-member
(define (generic-member cmp obj lst)
(cond
((null? lst) #f)
((cmp obj (car lst)) lst)
(else (generic-member cmp obj (cdr lst)))))
(define (memq obj lst)
(generic-member eq? obj lst))
(define (memv obj lst)
(generic-member eqv? obj lst))
(define (member obj lst)
(generic-member equal? obj lst))
;;;; generic-assoc
(define (generic-assoc cmp obj alst)
(cond
((null? alst) #f)
((cmp obj (caar alst)) (car alst))
(else (generic-assoc cmp obj (cdr alst)))))
(define (assq obj alst)
(generic-assoc eq? obj alst))
(define (assv obj alst)
(generic-assoc eqv? obj alst))
(define (assoc obj alst)
(generic-assoc equal? obj alst))
(define (acons x y z) (cons (cons x y) z))
;;;; Handy for imperative programs
;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
(macro (define-with-return form)
`(define ,(cadr form)
(call/cc (lambda (return) ,@(cddr form)))))
;; Print the given history.
(define (vm-history-print history)
(let loop ((n 0) (skip 0) (frames history))
(cond
((null? frames)
#t)
((> skip 0)
(loop 0 (- skip 1) (cdr frames)))
(else
(let ((f (car frames)))
(display n)
(display ": ")
(let ((tag (get-tag f)))
(unless (null? tag)
(display (basename (car tag)))
(display ":")
(display (+ 1 (cdr tag)))
(display ": ")))
(write f))
(newline)
(loop (+ n 1) skip (cdr frames))))))
;;;; Simple exception handling
;
; Exceptions are caught as follows:
;
; (catch (do-something to-recover and-return meaningful-value)
; (if-something goes-wrong)
; (with-these calls))
;
; "Catch" establishes a scope spanning multiple call-frames until
; another "catch" is encountered. Within the recovery expression
; the thrown exception is bound to *error*. Errors can be rethrown
; using (rethrow *error*).
;
+; Finalization can be expressed using "finally":
+;
+; (finally (finalize-something called-purely-for side-effects)
+; (whether-or-not something goes-wrong)
+; (with-these calls))
+;
+; The final expression is executed purely for its side-effects,
+; both when the function exits successfully, and when an exception
+; is thrown.
+;
; Exceptions are thrown with:
;
; (throw "message")
;
; If used outside a (catch ...), reverts to (error "message")
(define *handlers* (list))
(define (push-handler proc)
(set! *handlers* (cons proc *handlers*)))
(define (pop-handler)
(let ((h (car *handlers*)))
(set! *handlers* (cdr *handlers*))
h))
(define (more-handlers?)
(pair? *handlers*))
;; This throws an exception.
(define (throw message . args)
(throw' message args (cdr (*vm-history*))))
;; This is used by the vm to throw exceptions.
(define (throw' message args history)
(cond
((more-handlers?)
((pop-handler) message args history))
((and args (list? args) (= 2 (length args))
(equal? *interpreter-exit* (car args)))
(*run-atexit-handlers*)
(quit (cadr args)))
(else
(display message)
(if args (begin
(display ": ")
(write args)))
(newline)
(vm-history-print history)
(quit 1))))
;; Convenience function to rethrow the error.
(define (rethrow e)
(apply throw' e))
(macro (catch form)
(let ((label (gensym)))
`(call/cc (lambda (**exit**)
(push-handler (lambda *error* (**exit** ,(cadr form))))
(let ((,label (begin ,@(cddr form))))
(pop-handler)
,label)))))
+(define-macro (finally final-expression . expressions)
+ (let ((result (gensym)))
+ `(let ((,result (catch (begin ,final-expression (rethrow *error*))
+ ,@expressions)))
+ ,final-expression
+ ,result)))
+
;; Make the vm use throw'.
(define *error-hook* throw')
;; High-level mechanism to terminate the process is to throw an error
;; of the form (*interpreter-exit* status). This gives automatic
;; resource management a chance to clean up.
(define *interpreter-exit* (gensym))
;; Terminate the process returning STATUS to the parent.
(define (exit status)
(throw "interpreter exit" *interpreter-exit* status))
;; A list of functions run at interpreter shutdown.
(define *atexit-handlers* (list))
;; Execute all these functions.
(define (*run-atexit-handlers*)
(unless (null? *atexit-handlers*)
(let ((proc (car *atexit-handlers*)))
;; Drop proc from the list so that it will not get
;; executed again even if it raises an exception.
(set! *atexit-handlers* (cdr *atexit-handlers*))
(proc)
(*run-atexit-handlers*))))
;; Register a function to be run at interpreter shutdown.
(define (atexit proc)
(set! *atexit-handlers* (cons proc *atexit-handlers*)))
;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
(macro (make-environment form)
`(apply (lambda ()
,@(cdr form)
(current-environment))))
(define-macro (eval-polymorphic x . envl)
(display envl)
(let* ((env (if (null? envl) (current-environment) (eval (car envl))))
(xval (eval x env)))
(if (closure? xval)
(make-closure (get-closure-code xval) env)
xval)))
; Redefine this if you install another package infrastructure
; Also redefine 'package'
(define *colon-hook* eval)
(macro (package form)
`(apply (lambda ()
,@(cdr form)
(current-environment))))
;;;;; I/O
(define (input-output-port? p)
(and (input-port? p) (output-port? p)))
(define (close-port p)
(cond
((input-output-port? p) (close-input-port p) (close-output-port p))
((input-port? p) (close-input-port p))
((output-port? p) (close-output-port p))
(else (throw "Not a port" p))))
(define (call-with-input-file s p)
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p)
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p)
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p)
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))
(define (with-input-output-from-to-files si so p)
(let ((inport (open-input-file si))
(outport (open-input-file so)))
(if (not (and inport outport))
(begin
(close-input-port inport)
(close-output-port outport)
#f)
(let ((prev-inport (current-input-port))
(prev-outport (current-output-port)))
(set-input-port inport)
(set-output-port outport)
(let ((res (p)))
(close-input-port inport)
(close-output-port outport)
(set-input-port prev-inport)
(set-output-port prev-outport)
res)))))
; Random number generator (maximum cycle)
(define *seed* 1)
(define (random-next)
(let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
(set! *seed*
(- (* a (- *seed*
(* (quotient *seed* q) q)))
(* (quotient *seed* q) r)))
(if (< *seed* 0) (set! *seed* (+ *seed* m)))
*seed*))
;; SRFI-0
;; COND-EXPAND
;; Implemented as a macro
(define *features* '(srfi-0 tinyscheme))
(define-macro (cond-expand . cond-action-list)
(cond-expand-runtime cond-action-list))
(define (cond-expand-runtime cond-action-list)
(if (null? cond-action-list)
#t
(if (cond-eval (caar cond-action-list))
`(begin ,@(cdar cond-action-list))
(cond-expand-runtime (cdr cond-action-list)))))
(define (cond-eval-and cond-list)
(foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
(define (cond-eval-or cond-list)
(foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
(define (cond-eval condition)
(cond
((symbol? condition)
(if (member condition *features*) #t #f))
((eq? condition #t) #t)
((eq? condition #f) #f)
(else (case (car condition)
((and) (cond-eval-and (cdr condition)))
((or) (cond-eval-or (cdr condition)))
((not) (if (not (null? (cddr condition)))
(error "cond-expand : 'not' takes 1 argument")
(not (cond-eval (cadr condition)))))
(else (error "cond-expand : unknown operator" (car condition)))))))
(gc-verbose #f)
diff --git a/tests.scm b/tests.scm
index f127a93..5954704 100644
--- a/tests.scm
+++ b/tests.scm
@@ -1,685 +1,676 @@
;; Common definitions for writing tests.
;;
;; Copyright (C) 2016 g10 Code GmbH
;;
;; This file is part of GnuPG.
;;
;; GnuPG is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;;
;; GnuPG is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, see .
;; Trace displays and returns the given value. A debugging aid.
(define (trace x)
(display x)
(newline)
x)
;; Stringification.
(define (stringify expression)
(let ((p (open-output-string)))
(write expression p)
(get-output-string p)))
;; Reporting.
(define (echo . msg)
(for-each (lambda (x) (display x) (display " ")) msg)
(newline))
(define (info . msg)
(apply echo msg)
(flush-stdio))
(define (log . msg)
(if (> (*verbose*) 0)
(apply info msg)))
(define (fail . msg)
(apply info msg)
(exit 1))
(define (skip . msg)
(apply info msg)
(exit 77))
(define (make-counter)
(let ((c 0))
(lambda ()
(let ((r c))
(set! c (+ 1 c))
r))))
(define *progress-nesting* 0)
(define (call-with-progress msg what)
(set! *progress-nesting* (+ 1 *progress-nesting*))
(if (= 1 *progress-nesting*)
(begin
(info msg)
(display " > ")
(flush-stdio)
(what (lambda (item)
(display item)
(display " ")
(flush-stdio)))
(info "< "))
(begin
(what (lambda (item) (display ".") (flush-stdio)))
(display " ")
(flush-stdio)))
(set! *progress-nesting* (- *progress-nesting* 1)))
(define (for-each-p msg proc lst . lsts)
(apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
(define (for-each-p' msg proc fmt lst . lsts)
(call-with-progress
msg
(lambda (progress)
(apply for-each
`(,(lambda args
(progress (apply fmt args))
(apply proc args))
,lst ,@lsts)))))
;; Process management.
(define CLOSED_FD -1)
(define (call-with-fds what infd outfd errfd)
(wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
(define (call what)
(call-with-fds what
CLOSED_FD
(if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
(if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
;; Accessor functions for the results of 'spawn-process'.
(define :stdin car)
(define :stdout cadr)
(define :stderr caddr)
(define :pid cadddr)
(define (call-with-io what in)
(let ((h (spawn-process what 0)))
(es-write (:stdin h) in)
(es-fclose (:stdin h))
(let* ((out (es-read-all (:stdout h)))
(err (es-read-all (:stderr h)))
(result (wait-process (car what) (:pid h) #t)))
(es-fclose (:stdout h))
(es-fclose (:stderr h))
(if (> (*verbose*) 2)
(begin
(echo (stringify what) "returned:" result)
(echo (stringify what) "wrote to stdout:" out)
(echo (stringify what) "wrote to stderr:" err)))
(list result out err))))
;; Accessor function for the results of 'call-with-io'. ':stdout' and
;; ':stderr' can also be used.
(define :retcode car)
(define (call-check what)
(let ((result (call-with-io what "")))
(if (= 0 (:retcode result))
(:stdout result)
(throw (string-append (stringify what) " failed")
(:stderr result)))))
(define (call-popen command input-string)
(let ((result (call-with-io command input-string)))
(if (= 0 (:retcode result))
(:stdout result)
(throw (:stderr result)))))
;;
;; estream helpers.
;;
(define (es-read-all stream)
(let loop
((acc ""))
(if (es-feof stream)
acc
(loop (string-append acc (es-read stream 4096))))))
;;
;; File management.
;;
(define (file-exists? name)
(call-with-input-file name (lambda (port) #t)))
(define (file=? a b)
(file-equal a b #t))
(define (text-file=? a b)
(file-equal a b #f))
(define (file-copy from to)
(catch '() (unlink to))
(letfd ((source (open from (logior O_RDONLY O_BINARY)))
(sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
(splice source sink)))
(define (text-file-copy from to)
(catch '() (unlink to))
(letfd ((source (open from O_RDONLY))
(sink (open to (logior O_WRONLY O_CREAT) #o600)))
(splice source sink)))
(define (path-join . components)
(let loop ((acc #f) (rest (filter (lambda (s)
(not (string=? "" s))) components)))
(if (null? rest)
acc
(loop (if (string? acc)
(string-append acc "/" (car rest))
(car rest))
(cdr rest)))))
(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
(assert (string=? (path-join "" "bar" "baz") "bar/baz"))
;; Is PATH an absolute path?
(define (absolute-path? path)
(or (char=? #\/ (string-ref path 0))
(and *win32* (char=? #\\ (string-ref path 0)))
(and *win32*
(char-alphabetic? (string-ref path 0))
(char=? #\: (string-ref path 1))
(or (char=? #\/ (string-ref path 2))
(char=? #\\ (string-ref path 2))))))
;; Make PATH absolute.
(define (canonical-path path)
(if (absolute-path? path) path (path-join (getcwd) path)))
(define (in-srcdir . names)
(canonical-path (apply path-join (cons (getenv "srcdir") names))))
;; Try to find NAME in PATHS. Returns the full path name on success,
;; or raises an error.
(define (path-expand name paths)
(let loop ((path paths))
(if (null? path)
(throw "Could not find" name "in" paths)
(let* ((qualified-name (path-join (car path) name))
(file-exists (call-with-input-file qualified-name
(lambda (x) #t))))
(if file-exists
qualified-name
(loop (cdr path)))))))
;; Expand NAME using the gpgscm load path. Use like this:
;; (load (with-path "library.scm"))
(define (with-path name)
(catch name
(path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*))))
(define (basename path)
(let ((i (string-index path #\/)))
(if (equal? i #f)
path
(basename (substring path (+ 1 i) (string-length path))))))
(define (basename-suffix path suffix)
(basename
(if (string-suffix? path suffix)
(substring path 0 (- (string-length path) (string-length suffix)))
path)))
;; Helper for (pipe).
(define :read-end car)
(define :write-end cadr)
;; let-like macro that manages file descriptors.
;;
;; (letfd )
;;
;; Bind all variables given in and initialize each of them
;; to the given initial value, and close them after evaluting .
-(macro (letfd form)
- (let ((result-sym (gensym)))
- `((lambda (,(caaadr form))
- (let ((,result-sym
- ,(if (= 1 (length (cadr form)))
- `(catch (begin (close ,(caaadr form))
- (rethrow *error*))
- ,@(cddr form))
- `(letfd ,(cdadr form) ,@(cddr form)))))
- (close ,(caaadr form))
- ,result-sym)) ,@(cdaadr form))))
-
-(macro (with-working-directory form)
- (let ((result-sym (gensym)) (cwd-sym (gensym)))
- `(let* ((,cwd-sym (getcwd))
- (_ (if ,(cadr form) (chdir ,(cadr form))))
- (,result-sym (catch (begin (chdir ,cwd-sym)
- (rethrow *error*))
- ,@(cddr form))))
- (chdir ,cwd-sym)
- ,result-sym)))
+(define-macro (letfd bindings . body)
+ (let bind ((bindings' bindings))
+ (if (null? bindings')
+ `(begin ,@body)
+ (let* ((binding (car bindings'))
+ (name (car binding))
+ (initializer (cadr binding)))
+ `(let ((,name ,initializer))
+ (finally (close ,name)
+ ,(bind (cdr bindings'))))))))
+
+(define-macro (with-working-directory new-directory . expressions)
+ (let ((new-dir (gensym))
+ (old-dir (gensym)))
+ `(let* ((,new-dir ,new-directory)
+ (,old-dir (getcwd)))
+ (dynamic-wind
+ (lambda () (if ,new-dir (chdir ,new-dir)))
+ (lambda () ,@expressions)
+ (lambda () (chdir ,old-dir))))))
;; Make a temporary directory. If arguments are given, they are
;; joined using path-join, and must end in a component ending in
;; "XXXXXX". If no arguments are given, a suitable location and
;; generic name is used.
(define (mkdtemp . components)
(_mkdtemp (if (null? components)
(path-join (getenv "TMP")
(string-append "gpgscm-" (get-isotime) "-"
(basename-suffix *scriptname* ".scm")
"-XXXXXX"))
(apply path-join components))))
-(macro (with-temporary-working-directory form)
- (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
- `(let* ((,cwd-sym (getcwd))
- (,tmp-sym (mkdtemp))
- (_ (chdir ,tmp-sym))
- (,result-sym (catch (begin (chdir ,cwd-sym)
- (unlink-recursively ,tmp-sym)
- (rethrow *error*))
- ,@(cdr form))))
- (chdir ,cwd-sym)
- (unlink-recursively ,tmp-sym)
- ,result-sym)))
+(define-macro (with-temporary-working-directory . expressions)
+ (let ((tmp-sym (gensym)))
+ `(let* ((,tmp-sym (mkdtemp)))
+ (finally (unlink-recursively ,tmp-sym)
+ (with-working-directory ,tmp-sym
+ ,@expressions)))))
(define (make-temporary-file . args)
(canonical-path (path-join
(mkdtemp)
(if (null? args) "a" (car args)))))
(define (remove-temporary-file filename)
(catch '()
(unlink filename))
(let ((dirname (substring filename 0 (string-rindex filename #\/))))
(catch (echo "removing temporary directory" dirname "failed")
(rmdir dirname))))
;; let-like macro that manages temporary files.
;;
;; (lettmp )
;;
;; Bind all variables given in , initialize each of them to
;; a string representing an unique path in the filesystem, and delete
;; them after evaluting .
-(macro (lettmp form)
- (let ((result-sym (gensym)))
- `((lambda (,(caadr form))
- (let ((,result-sym
- ,(if (= 1 (length (cadr form)))
- `(catch (begin (remove-temporary-file ,(caadr form))
- (rethrow *error*))
- ,@(cddr form))
- `(lettmp ,(cdadr form) ,@(cddr form)))))
- (remove-temporary-file ,(caadr form))
- ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
+(define-macro (lettmp bindings . body)
+ (let bind ((bindings' bindings))
+ (if (null? bindings')
+ `(begin ,@body)
+ (let ((name (car bindings'))
+ (rest (cdr bindings')))
+ `(let ((,name (make-temporary-file ,(symbol->string name))))
+ (finally (remove-temporary-file ,name)
+ ,(bind rest)))))))
(define (check-execution source transformer)
(lettmp (sink)
(transformer source sink)))
(define (check-identity source transformer)
(lettmp (sink)
(transformer source sink)
(if (not (file=? source sink))
(fail "mismatch"))))
;;
;; Monadic pipe support.
;;
(define pipeM
(package
(define (new procs source sink producer)
(package
(define (dump)
(write (list procs source sink producer))
(newline))
(define (add-proc command pid)
(new (cons (list command pid) procs) source sink producer))
(define (commands)
(map car procs))
(define (pids)
(map cadr procs))
(define (set-source source')
(new procs source' sink producer))
(define (set-sink sink')
(new procs source sink' producer))
(define (set-producer producer')
(if producer
(throw "producer already set"))
(new procs source sink producer'))))))
(define (pipe:do . commands)
(let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
(if (null? cmds)
(begin
(if M::producer (M::producer))
(if (not (null? M::procs))
(let* ((retcodes (wait-processes (map stringify (M::commands))
(M::pids) #t))
(results (map (lambda (p r) (append p (list r)))
M::procs retcodes))
(failed (filter (lambda (x) (not (= 0 (caddr x))))
results)))
(if (not (null? failed))
(throw failed))))) ; xxx nicer reporting
(if (and (= 2 (length cmds)) (number? (cadr cmds)))
;; hack: if it's an fd, use it as sink
(let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
(if (> M::source 2) (close M::source))
(if (> (cadr cmds) 2) (close (cadr cmds)))
(loop M' '()))
(let ((M' ((car cmds) M)))
(if (> M::source 2) (close M::source))
(loop M' (cdr cmds)))))))
(define (pipe:open pathname flags)
(lambda (M)
(M::set-source (open pathname flags))))
(define (pipe:defer producer)
(lambda (M)
(let* ((p (outbound-pipe))
(M' (M::set-source (:read-end p))))
(M'::set-producer (lambda ()
(producer (:write-end p))
(close (:write-end p)))))))
(define (pipe:echo data)
(pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
(define (pipe:spawn command)
(lambda (M)
(define (do-spawn M new-source)
(let ((pid (spawn-process-fd command M::source M::sink
(if (> (*verbose*) 0)
STDERR_FILENO CLOSED_FD)))
(M' (M::set-source new-source)))
(M'::add-proc command pid)))
(if (= CLOSED_FD M::sink)
(let* ((p (pipe))
(M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
(close (:write-end p))
(M'::set-sink CLOSED_FD))
(do-spawn M CLOSED_FD))))
(define (pipe:splice sink)
(lambda (M)
(splice M::source sink)
(M::set-source CLOSED_FD)))
(define (pipe:write-to pathname flags mode)
(open pathname flags mode))
;;
;; Monadic transformer support.
;;
(define (tr:do . commands)
(let loop ((tmpfiles '()) (source #f) (cmds commands))
(if (null? cmds)
(for-each remove-temporary-file tmpfiles)
(let* ((v ((car cmds) tmpfiles source))
(tmpfiles' (car v))
(sink (cadr v))
(error (caddr v)))
(if error
(begin
(for-each remove-temporary-file tmpfiles')
(apply throw error)))
(loop tmpfiles' sink (cdr cmds))))))
(define (tr:open pathname)
(lambda (tmpfiles source)
(list tmpfiles pathname #f)))
(define (tr:spawn input command)
(lambda (tmpfiles source)
(if (and (member '**in** command) (not source))
(fail (string-append (stringify cmd) " needs an input")))
(let* ((t (make-temporary-file))
(cmd (map (lambda (x)
(cond
((equal? '**in** x) source)
((equal? '**out** x) t)
(else x))) command)))
(catch (list (cons t tmpfiles) t *error*)
(call-popen cmd input)
(if (and (member '**out** command) (not (file-exists? t)))
(fail (string-append (stringify cmd)
" did not produce '" t "'.")))
(list (cons t tmpfiles) t #f)))))
(define (tr:write-to pathname)
(lambda (tmpfiles source)
(rename source pathname)
(list tmpfiles pathname #f)))
(define (tr:pipe-do . commands)
(lambda (tmpfiles source)
(let ((t (make-temporary-file)))
(apply pipe:do
`(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
,@commands
,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
(list (cons t tmpfiles) t #f))))
(define (tr:assert-identity reference)
(lambda (tmpfiles source)
(if (not (file=? source reference))
(fail "mismatch"))
(list tmpfiles source #f)))
(define (tr:assert-weak-identity reference)
(lambda (tmpfiles source)
(if (not (text-file=? source reference))
(fail "mismatch"))
(list tmpfiles source #f)))
(define (tr:call-with-content function . args)
(lambda (tmpfiles source)
(catch (list tmpfiles source *error*)
(apply function `(,(call-with-input-file source read-all) ,@args)))
(list tmpfiles source #f)))
;;
;; Developing and debugging tests.
;;
;; Spawn an os shell.
(define (interactive-shell)
(call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
;;
;; The main test framework.
;;
;; A pool of tests.
(define test-pool
(package
(define (new procs)
(package
(define (add test)
(new (cons test procs)))
(define (wait)
(let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
(if (null? unfinished)
(package)
(let* ((names (map (lambda (t) t::name) unfinished))
(pids (map (lambda (t) t::pid) unfinished))
(results
(map (lambda (pid retcode) (list pid retcode))
pids
(wait-processes (map stringify names) pids #t))))
(new
(map (lambda (t)
(if t::retcode
t
(t::set-retcode (cadr (assoc t::pid results)))))
procs))))))
(define (passed)
(filter (lambda (p) (= 0 p::retcode)) procs))
(define (skipped)
(filter (lambda (p) (= 77 p::retcode)) procs))
(define (hard-errored)
(filter (lambda (p) (= 99 p::retcode)) procs))
(define (failed)
(filter (lambda (p)
(not (or (= 0 p::retcode) (= 77 p::retcode)
(= 99 p::retcode))))
procs))
(define (report)
(define (print-tests tests message)
(unless (null? tests)
(apply echo (cons message
(map (lambda (t) t::name) tests)))))
(let ((failed' (failed)) (skipped' (skipped)))
(echo (length procs) "tests run,"
(length (passed)) "succeeded,"
(length failed') "failed,"
(length skipped') "skipped.")
(print-tests failed' "Failed tests:")
(print-tests skipped' "Skipped tests:")
(length failed')))))))
(define (verbosity n)
(if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
(define (locate-test path)
(if (absolute-path? path) path (in-srcdir path)))
;; A single test.
(define test
(package
(define (scm name path . args)
;; Start the process.
(define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
,(locate-test path)
,@args' ,@args) in out err))
(new name #f spawn-scm #f #f CLOSED_FD))
(define (binary name path . args)
;; Start the process.
(define (spawn-binary args' in out err)
(spawn-process-fd `(,path ,@args' ,@args) in out err))
(new name #f spawn-binary #f #f CLOSED_FD))
(define (new name directory spawn pid retcode logfd)
(package
(define (set-directory x)
(new name x spawn pid retcode logfd))
(define (set-retcode x)
(new name directory spawn pid x logfd))
(define (set-pid x)
(new name directory spawn x retcode logfd))
(define (set-logfd x)
(new name directory spawn pid retcode x))
(define (open-log-file)
(let ((filename (string-append (basename name) ".log")))
(catch '() (unlink filename))
(open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
(define (run-sync . args)
(letfd ((log (open-log-file)))
(with-working-directory directory
(let* ((p (inbound-pipe))
(pid (spawn args 0 (:write-end p) (:write-end p))))
(close (:write-end p))
(splice (:read-end p) STDERR_FILENO log)
(close (:read-end p))
(let ((t' (set-retcode (wait-process name pid #t))))
(t'::report)
t')))))
(define (run-sync-quiet . args)
(with-working-directory directory
(set-retcode
(wait-process
name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
(define (run-async . args)
(let ((log (open-log-file)))
(with-working-directory directory
(new name directory spawn
(spawn args CLOSED_FD log log)
retcode log))))
(define (status)
(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
(if (not t) "FAIL" (cadr t))))
(define (report)
(unless (= logfd CLOSED_FD)
(seek logfd 0 SEEK_SET)
(splice logfd STDERR_FILENO)
(close logfd))
(echo (string-append (status retcode) ":") name))))))
;; Run the setup target to create an environment, then run all given
;; tests in parallel.
(define (run-tests-parallel setup tests)
(lettmp (gpghome-tar)
(setup::run-sync '--create-tarball gpghome-tar)
(let loop ((pool (test-pool::new '())) (tests' tests))
(if (null? tests')
(let ((results (pool::wait)))
(for-each (lambda (t)
(catch (echo "Removing" t::directory "failed:" *error*)
(unlink-recursively t::directory))
(t::report)) (reverse results::procs))
(exit (results::report)))
(let* ((wd (mkdtemp))
(test (car tests'))
(test' (test::set-directory wd)))
(loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
(cdr tests')))))))
;; Run the setup target to create an environment, then run all given
;; tests in sequence.
(define (run-tests-sequential setup tests)
(lettmp (gpghome-tar)
(setup::run-sync '--create-tarball gpghome-tar)
(let loop ((pool (test-pool::new '())) (tests' tests))
(if (null? tests')
(let ((results (pool::wait)))
(for-each (lambda (t)
(catch (echo "Removing" t::directory "failed:" *error*)
(unlink-recursively t::directory)))
results::procs)
(exit (results::report)))
(let* ((wd (mkdtemp))
(test (car tests'))
(test' (test::set-directory wd)))
(loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
(cdr tests')))))))
;; Command line flag handling. Returns the elements following KEY in
;; ARGUMENTS up to the next argument, or #f if KEY is not in
;; ARGUMENTS.
(define (flag key arguments)
(cond
((null? arguments)
#f)
((string=? key (car arguments))
(let loop ((acc '())
(args (cdr arguments)))
(if (or (null? args) (string-prefix? (car args) "--"))
(reverse acc)
(loop (cons (car args) acc) (cdr args)))))
((string=? "--" (car arguments))
#f)
(else
(flag key (cdr arguments)))))
(assert (equal? (flag "--xxx" '("--yyy")) #f))
(assert (equal? (flag "--xxx" '("--xxx")) '()))
(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))