;;;; lambda+.scm
;;;; Kon Lovett, Aug '10

(module lambda+

  (;export
    define+
    (lambda+ bind-lambda+))

  (import
    scheme
    chicken
    (only srfi-1 append! reverse!))

  (require-library srfi-1)

;;

(define-syntax define+
  (syntax-rules ()

    ((_ ((?name ?arg ...) ?carg ...) ?body ...)
      (define+ (?name ?arg ...)
        (lambda+ (?carg ...) ?body ...) ) )

    ((_ ((?name . ?arg) ?carg ...) ?body ...)
      (define+ (?name . ?arg)
        (lambda+ (?carg ...) ?body ...) ) )

    ((_ ((?name ?arg ...) . ?carg) ?body ...)
      (define+ (?name ?arg ...)
        (lambda ?carg ?body ...) ) )

    ((_ ((?name . ?arg) . ?carg) ?body ...)
      (define+ (?name . ?arg)
        (lambda ?carg ?body ...) ) )

    ((_ (?name ?arg0 ?arg ...) ?body ...)
      (define ?name (lambda+ (?arg0 ?arg ...) ?body ...)) )

    ((_ (?name) ?body ...)
      (define (?name) ?body ...) )

    ((_ (?name . ?arg) ?body ...)
      (define (?name . ?arg) ?body ...) )

    ((_ ?name ?body)
      (define ?name ?body) ) ) )

;;

#; ;List oriented version with let-values
(define-syntax (lambda+ f r c)
  (let ((args (cadr f))
        (body (cddr f))
        (r_restargs (r 'restargs))
        (r__ (r '_))
        (r_lambda (r 'lambda))
        (r_bind-lambda+ (r 'bind-lambda+))
        (r_call-with-values (r 'call-with-values))
        (r_list (r 'list)) )
    (call-with-values
      (lambda () (parse-lambda+ args))
      (lambda (rqrs opts rstvar keys)
        ; make keywords for matching
        (let ((minargc (length rqrs))
              (maxarg (fx+ minargc (length opts))) )
          (let ((kwds
                  (map
                    (lambda (x)
                      (cons (string->keyword (##sys#symbol->string (car x))) (cdr x)))
                     keys)))
            ; actual lambda
            `(,r_lambda ,(if (null? rqrs) r_restargs `(,@rqrs . ,r_restargs))
              (,r_call-with-values
                (,r_lambda ()
                  (,r_bind-lambda+
                    (,r_list ,@(map (lambda (l) `(cons ',(car l) ,(cdr l))) opts))
                    (,r_list ,@(map (lambda (l) `(cons ,(car l) ,(cdr l))) kwds))
                    ',rstvar
                    ,r_restargs) )
                (,r_lambda (,(or rstvar r__) ,@(map car opts) ,@(map car keys))
                  ,@body ) ) ) ) ) ) ) ) )

;The "ignore" rest variable '_' is probably unnecessary since when no formal
;rest arguments specified then bind-lambda+ will error if there are any actual
;rest arguments. The wasted vector slot for the rest is not worth the complexity
;of eliding it in this case.

(define-syntax (lambda+ f r c)
  (let ((args (cadr f))
        (body (cddr f))
        (r_restargs (r 'restargs))
        (r__ (r '_))
        (r_valvec (r 'valvec))
        (r_lambda (r 'lambda))
        (r_vector-ref (r 'vector-ref))
        (r_bind-lambda+ (r 'bind-lambda+))
        (r_call-with-values (r 'call-with-values))
        (r_list (r 'list)) )
    (call-with-values
      (lambda () (parse-lambda+ args))
      (lambda (rqrs opts rstvar keys)
        (let* ((optslen (length opts))
               (keyslen (length keys))
               (keypos (fx+ optslen 1))
               (size (fx+ keypos keyslen))
               (optvars (map car opts))
               (optdefs (map cdr opts))
               (keyvars (map car keys))
               ; make keywords for matching
               (kwds
                (map
                  (lambda (p)
                    (cons
                      (string->keyword (##sys#symbol->string (car p)))
                      (cdr p)) )
                   keys)) )
          ; actual lambda
          (cond
            ; simple
            ((and (null? opts) (null? keys))
              (if (not rstvar) `(,r_lambda (,@rqrs) ,@body)
                `(,r_lambda ,(if (null? rqrs) rstvar `(,@rqrs . ,rstvar))
                  ,@body ) ) )
            ; complex
            (else
              `(,r_lambda ,(if (null? rqrs) r_restargs `(,@rqrs . ,r_restargs))
                (let ((,r_valvec
                        (,r_bind-lambda+
                          ,optslen ,keypos ,size
                          (,r_list ,@optdefs)
                          (,r_list ,@(map (lambda (l) `(cons ,(car l) ,(cdr l))) kwds))
                          ',rstvar
                          ,r_restargs)))
                  (let ((,(or rstvar r__) (vector-ref ,r_valvec 0))
                        ,@(let loop ((idx 1)
                                     (optvars optvars)
                                     (letspc '()))
                            (if (null? optvars) letspc
                              (loop (fx+ idx 1)
                                    (cdr optvars)
                                    (cons
                                      `(,(car optvars) (,r_vector-ref ,r_valvec ,idx))
                                      letspc)) ) )
                        ,@(let loop ((idx (fx+ optslen 1))
                                     (keyvars keyvars)
                                     (letspc '()))
                            (if (null? keyvars) letspc
                              (loop (fx+ idx 1)
                                    (cdr keyvars)
                                    (cons
                                      `(,(car keyvars) (,r_vector-ref ,r_valvec ,idx))
                                      letspc)) ) ) )
                    ,@body ) ) ) ) ) ) ) ) ) )

;;

(define-for-syntax (identifier? obj)
  (let ((sanobj (strip-syntax obj)))
    (and (symbol? sanobj)
         (not (keyword? sanobj))) ) )

;;

(define-for-syntax (parse-lambda+ args)
  (let loop ((mode 'required) (args args) (rqrs '()) (opts '()) (rest #f) (keys '()))
    (cond
      ((null? args)
        (values (reverse! rqrs) (reverse! opts) (or rest #f) (reverse! keys)) )
      ((identifier? args)
        (cond
          ((not rest)
            (loop #f '() rqrs opts args keys) )
          (else
            (syntax-error 'lambda+ "duplicate rest arguments" rest args) ) ) )
      ((not (pair? args))
        (syntax-error 'lambda+ "invalid rest argument - not an identifier" args) )
      (else
        (let ((arg (car args))
              (args (cdr args)) )
          (case mode
            ((required)
              (cond
                ((eq? arg '#!optional)
                  (loop 'optional args rqrs opts rest keys) )
                ((eq? arg '#!rest)
                  (loop 'rest args rqrs opts rest keys) )
                ((eq? arg '#!key)
                  (loop 'key args rqrs opts rest keys) )
                ((identifier? arg)
                 (loop 'required args (cons arg rqrs) opts rest keys) )
                (else
                  (syntax-error 'lambda+ "invalid required argument - not an identifier" arg) ) ) )
            ((optional)
              (cond
                ((eq? arg '#!rest)
                  (loop 'rest args rqrs opts rest keys) )
                ((eq? arg '#!key)
                  (loop 'key args rqrs opts rest keys) )
                ((identifier? arg)
                 (loop 'optional args rqrs (cons (cons arg #f) opts) rest keys) )
                ((list? arg)
                  (if (and (pair? arg) (pair? (cdr arg)) (null? (cddr arg))
                           (identifier? (car arg)))
                    (loop 'optional args rqrs (cons (cons (car arg) (cadr arg)) opts) rest keys)
                    (syntax-error 'lambda+ "invalid optional argument specification" arg) ) )
                (else
                  (syntax-error 'lambda+ "invalid optional argument specification" arg) ) ) )
            ((rest)
              (cond
                ((eq? arg '#!key)
                  (loop 'key args rqrs opts rest keys) )
                ((identifier? arg)
                 (loop '!rest args rqrs opts arg keys) )
                (else
                  (syntax-error 'lambda+ "invalid rest argument - not an identifier" arg) ) ) )
            ((!rest)
              (cond
                ((eq? arg '#!key)
                  (loop 'key args rqrs opts rest keys) )
                (else
                  (syntax-error 'lambda+ "too many arguments - only #!key after #!rest" (cons arg args)) ) ) )
            ((key)
              (cond
                ((identifier? arg)
                 (loop 'key args rqrs opts rest (cons (cons arg #f) keys)) )
                ((list? arg)
                  (if (and (pair? arg) (pair? (cdr arg)) (null? (cddr arg))
                           (identifier? (car arg)))
                    (loop 'key args rqrs opts rest (cons (cons (car arg) (cadr arg)) keys))
                    (syntax-error 'lambda+ "invalid keyword argument specification" arg) ) )
                (else
                  (syntax-error 'lambda+ "invalid keyword argument specification" arg) ) ) ) ) ) ) ) ) )

;;

; Should stop optional assignment after 1st kwd arg?
;
; No, keyword arguments can be anywhere after the required arguments.

;This is no way useable in a more general context!

#; ;List oriented version
(define (bind-lambda+ opts0 keys hasrst? restargs)
  ; Uses the opts & keys as a simple db.
  (let loop ((opts opts0) (args restargs) (rest '()))
    (if (null? args)
      (if (not (or hasrst? (null? rest)))
        (##sys#signal-hook #:arity-error #f "too many arguments") ;FIXME
        (apply values (reverse! rest) (append! (map cdr opts0) (map cdr keys))) )
      (let ((arg (car args))
            (args (cdr args)) )
        (cond
          ((and (keyword? arg) (assq arg keys))
            =>
            (lambda (key)
              (if (null? args)
                (error "missing value for keyword" (car key))
                (begin
                  (set-cdr! key (car args))
                  (loop opts (cdr args) rest) ) ) ) )
          ((null? opts)
            (loop '() args (cons arg rest)) )
          (else
            (set-cdr! (car opts) arg)
            (loop (cdr opts) args rest) ) ) ) ) ) )

(define (bind-lambda+ optslen keypos size opts keys hasrst? restargs)
  ;
  (let ((vec (make-vector size)))
    ; initialize optionals to defaults
      ;could have lambda+ build a optdefs vector &
      ;movmem it into position in vec
    (unless (null? opts)
      (do ((i 1 (fx+ i 1))
           (opts opts (cdr opts)) )
          ((fx= keypos i))
        (vector-set! vec i (car opts)) ) )
    ; Uses the keys as a simple db.
    (let loop ((opts opts) (optidx 1) (args restargs) (rest '()))
      (if (null? args)
        (if (not (or hasrst? (null? rest)))
          (##sys#signal-hook #:arity-error #f "too many arguments") ;FIXME
          (begin
            ; remaining arguments
            (vector-set! vec 0 (reverse! rest))
            ; set keys to final values
            (unless (null? keys)
              (do ((i keypos (fx+ i 1))
                   (keys keys (cdr keys)) )
                  ((fx= size i) vec)
                (vector-set! vec i (cdar keys)) ) ) ) )
        (let ((arg (car args))
              (args (cdr args)) )
          (cond
            ((and (keyword? arg) (assq arg keys))
              =>
              (lambda (key)
                (if (null? args)
                  (error "missing value for keyword" (car key))
                  (begin
                    (set-cdr! key (car args))
                    (loop opts optidx (cdr args) rest) ) ) ) )
            ((null? opts)
              (loop '() #f args (cons arg rest)) )
            (else
              (vector-set! vec optidx arg)
              (loop (cdr opts) (fx+ optidx 1) args rest) ) ) ) ) ) ) )

) ;module lambda+