;; lambda-m.scm - (c) rohan drape, 2000-2007

(module lambda-m mzscheme
(require (only (lib "1.ss" "srfi") drop every find find-tail list-index take)
	 (only (lib "plt-match.ss") match-let))
(require-for-syntax (only (lib "stx.ss" "syntax") module-or-top-identifier=?))
;;(require (only-in (lib "1.ss" "srfi") drop every find find-tail list-index take)
;;	 (only-in (lib "plt-match.ss") match-let)
;;	 (for-syntax syntax/stx))
(provide let-m1 lambda-ml lambda-m define-m)

;; An interface to match-let. Restricted to <pairs>, <list>s,
;; <vector>s and <struct>s - and *without* an implicit begin.  The
;; struct syntax is abbreviated, it does not require the 'struct'
;; keyword or the parentheses around the fields.

(define-syntax let-m1
  (lambda (stx)
    (syntax-case*
     stx (list cons vector) module-or-top-identifier=?
     ((_ (list n ...) v e)   (syntax (match-let (((list n ...) v)) e)))
     ((_ (cons n0 n1) v e)   (syntax (match-let (((list-rest n0 n1) v)) e)))
     ((_ (vector n ...) v e) (syntax (match-let (((vector n ...) v)) e)))
     ((_ (type n ...) v e)   (syntax (match-let (((struct type (n ...)) v)) e)))
     ((_ n v e)              (syntax (let ((n v)) e))))))

(define-syntax let-m*
  (syntax-rules ()
    ((_ ((n v)) e)               (let-m1 n v e))
    ((_ ((n0 v0) (n1 v1) ...) e) (let-m1 n0 v0 (let-m* ((n1 v1) ...) e)))))

(define-syntax lambda-ml
  (syntax-rules ()
    ((_ l (n)        e) (l (v)        (let-m* ((n v))                   e)))
    ((_ l (n0 n1)    e) (l (v0 v1)    (let-m* ((n0 v0) (n1 v1))         e)))
    ((_ l (n0 n1 n2) e) (l (v0 v1 v2) (let-m* ((n0 v0) (n1 v1) (n2 v2)) e)))
    ;; ...
    ((_ l (n0 n1 n2 n3) e) (l (v0 v1 v2 v3) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3)) e)))
    ((_ l (n0 n1 n2 n3 n4) e) (l (v0 v1 v2 v3 v4) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5) e) (l (v0 v1 v2 v3 v4 v5) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6) e) (l (v0 v1 v2 v3 v4 v5 v6) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7) e) (l (v0 v1 v2 v3 v4 v5 v6 v7) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7 n8) e) (l (v0 v1 v2 v3 v4 v5 v6 v7 v8) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7) (n8 v8)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9) e) (l (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7) (n8 v8) (n9 v9)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 nA) e) (l (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vA) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7) (n8 v8) (n9 v9) (nA vA)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 nA nB) e) (l (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vA vB) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7) (n8 v8) (n9 v9) (nA vA) (nB vB)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 nA nB nC) e) (l (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vA vB vC) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7) (n8 v8) (n9 v9) (nA vA) (nB vB) (nC vC)) e)))
    ((_ l (n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 nA nB nC nD) e) (l (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vA vB vC vD) (let-m* ((n0 v0) (n1 v1) (n2 v2) (n3 v3) (n4 v4) (n5 v5) (n6 v6) (n7 v7) (n8 v8) (n9 v9) (nA vA) (nB vB) (nC vC) (nD vD)) e)))))

#|

;; The above is appalling - I don't know if this can be done without
;; resort to syntax-case - the above generates the temporaries (vN) by
;; hand...

(define-syntax lambda-ml*
  (syntax-rules ()
    ((_ l (n ...) (v ...) e) (lambda (v ...) (let-m* ((n v) ...) e)))
    ;; ...
    ((_ l (n)             e) (lambda-ml* l (n)         (v)         e))
    ((_ l (n0 n1)         e) (lambda-ml* l (n0 n1)     (v0 v1)     e))
    ((_ l (n0 n1 ...)     e) (lambda-ml* l (n0 n1 ...) (v0 v1 ...) e))))

|#

(define-syntax lambda-m
  (syntax-rules ()
    ((_ (n ...) e) (lambda-ml lambda (n ...) e))))

(define-syntax define-m
  (syntax-rules ()
    ((_ (n v ...) e) (define n (lambda-m (v ...) e)))
    ((_ n v)         (define n v))))

)

;; Local Variables:
;; truncate-lines:t
;; End: