[Chicken-janitors] #1491: ##sys#expand-multiple-values-assignment works for some reason

[Chicken Trac]

#1491: ##sys#expand-multiple-values-assignment works for some reason
----------------------+--------------------------------
 Reporter:  megane    |                 Owner:
     Type:  defect    |                Status:  new
 Priority:  minor     |             Milestone:  someday
Component:  expander  |               Version:  5.0
 Keywords:            |  Estimated difficulty:  medium
----------------------+--------------------------------
 Replace the original with this. I have only added the `print` and the
 `import`.
   {{{
   (import chicken.type)
   (define (##sys#expand-multiple-values-assignment formals expr)
     (##sys#decompose-lambda-list
      formals
      (lambda (vars argc rest)
        (let ((aliases    (if (symbol? formals) '() (map gensym formals)))
              (rest-alias (if (not rest) '() (gensym rest))))
          (print "formals: " formals
                 " list?: "(list? (the * formals))
                 " aliases: " aliases
                 " rest " rest-alias)
          `(##sys#call-with-values
            (##core#lambda () ,expr)
            (##core#lambda
             ,(append aliases rest-alias)
             ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)
             ,@(cond
                 ((null? formals) '((##core#undefined)))
                 ((null? rest-alias) '())
                 (else `((##core#set! ,rest ,rest-alias))))))))))
   }}}

 Now check the output of this. Pay attention to the `(d . e)` case. It's
 not a list, but somehow the `(map gensym formals)` expression runs without
 errors.
   {{{
   (let ([e '(0 1 2 3 (4) (5 6))]
         [r (letrec-values ((() (values))
                            ((a) (values 0))
                            ((b c) (values 1 2))
                            ((d . e) (values 3 4))
                            (f (values 5 6)))
                           (list a b c d e f))])
     (print e)
     (print r)
     (assert (equal? e r)))

   -->
   $ csc ../letrecvalues.scm && ../letrecvalues
   formals: () list?: #t aliases: () rest ()
   formals: (a) list?: #t aliases: (a11) rest ()
   formals: (b c) list?: #t aliases: (b12 c13) rest ()
   formals: (d . e) list?: #f aliases: (d14) rest e15
   formals: f list?: #f aliases: () rest f16
   (0 1 2 3 (4) (5 6))
   (0 1 2 3 (4) (5 6))
   }}}

 I think the correct implementation is something more like this:
 {{{
 (define (##sys#expand-multiple-values-assignment formals expr)
   (##sys#decompose-lambda-list
    formals
    (lambda (vars argc rest)
      (let* ((aliases    (if (symbol? formals) '() (map gensym vars)))
             (rest-alias (and rest (gensym rest))))
        `(##sys#call-with-values
          (##core#lambda () ,expr)
          (##core#lambda
           ,(cond
             [(symbol? formals) rest-alias]
             [(and rest (null? (cdr vars))) rest-alias]
             [(null? aliases) aliases]
             [rest (let lp ([vs aliases])
                     (if (null? (cdr vs))
                         (car vs)
                         (cons (car vs) (lp (cdr vs)))))]
             [else aliases])
           ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)
           ,@(cond
              [(symbol? formals) `((##core#set! ,rest ,rest-alias))]
              [else '((begin))])))))))
 }}}

--
Ticket URL: <https://bugs.call-cc.org/ticket/1491>
CHICKEN Scheme <https://www.call-cc.org/>
CHICKEN Scheme is a compiler for the Scheme programming language.