Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 14:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

using ER let-keyword-form, removing match dependency

Browse source
This commit is contained in:
Alex Shinn 2009-12-12 16:58:31 +09:00
parent d2e094e4c1
commit 3d02285732
2 changed files with 35 additions and 75 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
lib/chibi/loop.module
View file

@ -5,6 +5,5 @@
summing multiplying in-string in-string-reverse summing multiplying in-string in-string-reverse
in-vector in-vector-reverse) in-vector in-vector-reverse)
(import (scheme)) (import (scheme))
(import (chibi match))
(include "loop/loop.scm")) (include "loop/loop.scm"))

109
lib/chibi/loop/loop.scm
View file

@ -9,83 +9,44 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (assoc-pred equal elt ls)
(and (pair? ls)
(if (equal elt (car (car ls)))
(car ls)
(assoc-pred equal elt (cdr ls)))))
(define-syntax let-keyword-form (define-syntax let-keyword-form
(syntax-rules () (syntax-rules ()
((let-keyword-form ((let-keyword-form
((labeled-arg-macro-name ((labeled-arg-macro-name (positional-name . params)))
(positional-form-name (arg-name . arg-default) ...)))
. body) . body)
(letrec-syntax (let-syntax
((labeled-arg-macro-name ((labeled-arg-macro-name
(syntax-rules () (er-macro-transformer
((labeled-arg-macro-name . keyword-val-pairs) (lambda (expr rename compare)
(letrec-syntax (let lp ((ls (cdr expr)) (named '()) (posns '()))
((find (cond
(syntax-rules (=> arg-name ...) ((pair? ls)
((find kvp k-args (arg-name . default) (=> arg-name val) (if (and (list? (car ls)) (compare (caar ls) (rename '=>)))
. others) ; found arg-name among keyword-val-pairs (lp (cdr ls) (cons (cdar ls) named) posns)
(next kvp val . k-args)) ... (lp (cdr ls) named (cons (car ls) posns))))
((find kvp k-args key (=> arg-no-match-name val) . others) (else
(find kvp k-args key . others)) (let lp ((ls (syntax-quote params))
;; default must be here (posns (reverse posns))
((find kvp k-args (arg-name default)) (args '()))
(next kvp default . k-args)) ... (cond
)) ((null? ls)
(next ; pack the continuation to find (if (pair? posns)
(syntax-rules () (error "let-keyword-form: too many args" expr)
((next kvp val vals key . keys) (cons (syntax-quote positional-name) (reverse args))))
(find kvp ((val . vals) . keys) key . kvp)) ((assoc-pred compare (caar ls) named)
((next kvp val vals) ; processed all arg-descriptors => (lambda (x) (lp (cdr ls) posns (cons (cadr x) args))))
(rev-apply (val) vals)))) ((pair? posns)
(match-positionals (lp (cdr ls) (cdr posns) (cons (car posns) args)))
(syntax-rules (=>) (else
((match-positionals () res . rest) (lp (cdr ls) posns (cons (cadar ls) args))))))))))))
(rev-apply () res))
((match-positionals args (val . vals) (=> name value)
. rest)
(next ((=> name value) . rest) val vals . args))
((match-positionals args (val . vals))
(next () val vals . args))
((match-positionals (arg1 . args) res pos-arg . rest)
(match-positionals args (pos-arg . res) . rest))))
(rev-apply
(syntax-rules ()
((rev-apply form (x . xs))
(rev-apply (x . form) xs))
((rev-apply form ()) form))))
(match-positionals ((arg-name . arg-default) ...)
(positional-form-name)
. keyword-val-pairs)
)))))
. body)))) . body))))
;; (define-syntax let-keyword-form
;; (syntax-rules ()
;; ((let-keyword-form
;; ((labeled-arg-macro-name (positional-name (arg default) ...)))
;; . body)
;; (letrec-syntax
;; ((labeled-arg-macro-name
;; (er-macro-transformer
;; (lambda (expr rename compare)
;; (receive (named posns)
;; (partition (lambda (x) (and (list? x) (compare (car x) (rename '=>))))
;; (cdr expr))
;; (let lp ((ls '((arg default) ...)) (posns posns) (args '()))
;; (cond
;; ((null? ls)
;; (if (pair? posns)
;; (error "let-keyword-form: too many args" expr)
;; (cons 'positional-name (reverse args))))
;; ((find (lambda (x) (compare (caar ls) (cadr x))) named)
;; => (lambda (x)
;; (lp (cdr ls) posns (cons (caddr x) args))))
;; ((pair? posns)
;; (lp (cdr ls) (cdr posns) (cons (car posns) args)))
;; (else
;; (lp (cdr ls) posns (cons (cadar ls) args))))))))))
;; . body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax loop (define-syntax loop
@ -137,8 +98,8 @@
(letrec ((tmp (lambda (var ...) (letrec ((tmp (lambda (var ...)
(if (or checks ...) (if (or checks ...)
(let-keyword-form ((name (tmp (var step) ...))) (let-keyword-form ((name (tmp (var step) ...)))
(match-let (finals ...) result)) (let (finals ...) result))
(match-let (refs ...) (let (refs ...)
(let-keyword-form ((name (tmp (var step) ...))) (let-keyword-form ((name (tmp (var step) ...)))
(if #f #f) (if #f #f)
. body)))))) . body))))))
@ -380,8 +341,8 @@
((listing-reverse args next . rest) ((listing-reverse args next . rest)
(accumulating (cons (lambda (x) x) '()) args next . rest)))) (accumulating (cons (lambda (x) x) '()) args next . rest))))
(define (append-reverse ls1 ls2) (define (append-reverse rev tail)
(append (reverse ls1) ls2)) (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
(define-syntax appending (define-syntax appending
(syntax-rules () (syntax-rules ()