diff --git a/srfi-13.scm b/srfi-13.scm index 9840038..5804ed7 100644 --- a/srfi-13.scm +++ b/srfi-13.scm @@ -121,24 +121,42 @@ ;;; This macro parses optional start/end arguments from arg lists, defaulting ;;; them to 0/(string-length s), and checks them for correctness. -(define-syntax let-string-start+end - (syntax-rules () - ((let-string-start+end (start end) proc s-exp args-exp body ...) - (receive (start end) (string-parse-final-start+end proc s-exp args-exp) - body ...)) - ((let-string-start+end (start end rest) proc s-exp args-exp body ...) - (receive (rest start end) (string-parse-start+end proc s-exp args-exp) - body ...)))) +(define-macro (let-string-start+end args proc s-exp args-exp . body) + (case (length args) + ((2) `(receive ,args + (string-parse-final-start+end ,proc ,s-exp ,args-exp) + ,@body)) + ((3) `(receive ,args + (string-parse-start+end ,proc ,s-exp ,args-exp) + ,@body)) + (else (error "Wrong syntax for let-string-start+end")))) + +;;(define-syntax let-string-start+end +;; (syntax-rules () +;; ((let-string-start+end (start end) proc s-exp args-exp body ...) +;; (receive (start end) (string-parse-final-start+end proc s-exp args-exp) +;; body ...)) +;; ((let-string-start+end (start end rest) proc s-exp args-exp body ...) +;; (receive (rest start end) (string-parse-start+end proc s-exp args-exp) +;; body ...)))) ;;; This one parses out a *pair* of final start/end indices. ;;; Not exported; for internal use. -(define-syntax let-string-start+end2 - (syntax-rules () - ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...) - (let ((procv proc)) ; Make sure PROC is only evaluated once. - (let-string-start+end (start1 end1 rest) procv s1 args - (let-string-start+end (start2 end2) procv s2 rest - body ...)))))) + +(define-macro (let-string-start+end2 argspos proc s1 s2 args . body) + (let ((rest (gensym))) + `(let ((procv ,proc)) ; Make sure PROC is only evaluated once. + (let-string-start+end (,(car argspos) ,(cadr argspos) ,rest) procv ,s1 ,args + (let-string-start+end (,(caddr argspos) ,(cadddr argspos)) procv ,s2 ,rest + ,@body))))) + +;;(define-syntax let-string-start+end2 +;; (syntax-rules () +;; ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...) +;; (let ((procv proc)) ; Make sure PROC is only evaluated once. +;; (let-string-start+end (start1 end1 rest) procv s1 args +;; (let-string-start+end (start2 end2) procv s2 rest +;; body ...)))))) ;;; Returns three values: rest start end diff --git a/srfi-14.scm b/srfi-14.scm index 0e33ec1..60f3d8e 100644 --- a/srfi-14.scm +++ b/srfi-14.scm @@ -67,6 +67,61 @@ ;;; See the end of the file for porting and performance-tuning notes. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (%latin1->char char) +(integer->char char) +) + +(define (%char->latin1 char) +(char->integer char) +) + +(define-macro (let-optionals* datum args . body) + (let ((arg-name (gensym))) + (let loop ((args args) + (let-arguments '()) + (set-let '()) + (if-checking '())) + (if (pair? args) + (cond + ((and (not (pair? (car args))) (not (pair? (cdr args)))) + ;; rest + (loop (cdr args) + (cons `(,(car args) '()) let-arguments) + (cons `(if (pair? ,arg-name) (set! ,(car args) ,arg-name)) set-let) + if-checking)) + ((and (pair? (car args)) (equal? (length (car args)) 2)) + ;; without checking + (loop (cdr args) + (cons (list (caar args) (cadar args)) let-arguments) + (cons `(if (pair? ,arg-name) (begin (set! ,(caar args) (car ,arg-name)) (set! ,arg-name (cdr ,arg-name)))) set-let) + if-checking)) + ((and (pair? (car args)) (equal? (length (car args)) 3)) + ;; with checking + (loop (cdr args) + (cons (list (caar args) (cadar args)) let-arguments) + (cons `(if (pair? ,arg-name) (begin (set! ,(caar args) (car ,arg-name)) (set! ,arg-name (cdr ,arg-name)))) set-let) + (cons (caddar args) if-checking))) + (else (error "invalid let-optionals*"))) + `(let ((,arg-name ,datum)) + (let* (,@(reverse let-arguments)) + ,@(reverse set-let) + (if (and #t ,@(reverse if-checking)) + (begin ,@body) + (error "wrong arguments")))))))) + +(define-macro (:optional . args) + (case (length args) + ((2) + `(if (equal? ,(car args) '()) ,(cadr args) ,(car args)) + ) + ((3) + `(if (and (not (equal? ,(car args) '())) + (,(caddr args) ,(car args))) ,(car args) ,(cadr args))) + (else "wrong arguments passed to :optional"))) + +(define-macro (check-arg . rest) + (void)) + (define-record-type :char-set (make-char-set s) char-set? @@ -338,7 +393,7 @@ chars)) (define (char-set . chars) - (let ((s (make-string 256 c0))) + (let ((s (make-string 256 #\nul))) (%list->char-set! chars s) (make-char-set s)))