diff options
Diffstat (limited to 'src/guile/skribe')
-rw-r--r-- | src/guile/skribe/debug.scm | 5 | ||||
-rw-r--r-- | src/guile/skribe/lib.scm | 29 |
2 files changed, 23 insertions, 11 deletions
diff --git a/src/guile/skribe/debug.scm b/src/guile/skribe/debug.scm index 01f88c2..e2bff27 100644 --- a/src/guile/skribe/debug.scm +++ b/src/guile/skribe/debug.scm @@ -25,7 +25,8 @@ (define-module (skribe debug) - :export (debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol + :export (with-debug %with-debug + debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol no-debug-color)) (define *skribe-debug* 0) @@ -138,7 +139,7 @@ r))) (define-macro (with-debug level label . body) - `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body))) + `(%with-debug ,level ,label (lambda () ,@body))) ;;(define-macro (with-debug level label . body) ;; `(begin ,@body)) diff --git a/src/guile/skribe/lib.scm b/src/guile/skribe/lib.scm index 4a9b471..fa5e962 100644 --- a/src/guile/skribe/lib.scm +++ b/src/guile/skribe/lib.scm @@ -29,23 +29,34 @@ ;;; ;;; NEW ;;; -(define (maybe-copy obj) - (if (pair-mutable? obj) - obj - (copy-tree obj))) - (define-macro (new class . parameters) - `(make ,(string->symbol (format "<~a>" class)) + `(make ,(string->symbol (format #f "<~a>" class)) ,@(apply append (map (lambda (x) - `(,(make-keyword (car x)) (maybe-copy ,(cadr x)))) + `(,(symbol->keyword (car x)) ,(cadr x))) parameters)))) ;;; ;;; DEFINE-MARKUP ;;; (define-macro (define-markup bindings . body) - ;; This is just a STklos extended lambda. Nothing to do - `(define ,bindings ,@body)) + ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL + ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the + ;; `#:rest' argument can only appear last which not what Skribe/DSSSL + ;; expect, hence `fix-rest-arg'. + (define (fix-rest-arg args) + (let loop ((args args) + (result '()) + (rest-arg #f)) + (if (null? args) + (if rest-arg (append (reverse result) rest-arg) (reverse result)) + (let ((is-rest-arg? (eq? (car args) #:rest))) + (loop (if is-rest-arg? (cddr args) (cdr args)) + (if is-rest-arg? result (cons (car args) result)) + (if is-rest-arg? (list (car args) (cadr args)) rest-arg)))))) + + (let ((name (car bindings)) + (opts (cdr bindings))) + `(define* ,(cons name (fix-rest-arg opts)) ,@body))) ;;; |