All pastes #903712 Raw Edit

Quack destructuring until so far

public text v1 · immutable
·published 2008-02-14 12:18 UTC
rendered paste body
(evll-def

  (def matchfail (format . args)
    (apply error (strcat "Matching fail: " format) args))

  ;; A place here is something you can bind to. For example, a symbol, or
  ;; (list a b).
  ;;
  ;; fn* is like fn, but the functions it creates only take one argument.
  (macenv fn* env (place . body)
    (cond
      ;; Require equality
      (number? place)
        `(fn* ',place ,@body)
      ;; Usual let behaviour: bind a symbol
      (symbol? place)
        (if (or (null place)
                (keyword? place)
                (and (finddb place env)
                     (not (eq '_ place))))
          ;; Require equality
          `(fn* ',place ,@body)
          ;; Bind a fresh symbol
          `(fn (,place) ,@body))
      ;; bind a fn-macro
      (cons? place)
        (with-gensyms valsym
          (cond
            (eq (car place) 'cons)
              (do (assert (eq (length place) 3)
                          "fn*/cons: illegal syntax: ~s" place)
                 `(fn (,valsym)
                    (assert (cons? ,valsym) "fn*/cons/runtime: can't match ~s to ~s." ,valsym ',place)
                    (let* ,(second place) (car ,valsym)
                      (let* ,(third place) (cdr ,valsym)
                        ,@body))))
            (eq (car place) 'list)
              (if (cdr place)
                ;; > 0 elements
                `(fn (,valsym)
                     (assert (and (list? ,valsym)
                                  (eq (length ,valsym) ,(- (length place) 1)))
                             "fn*/list/runtime: wrong list for ~s: ~s." ',place ,valsym)
                     (let* (cons ,(cadr place) (list ,@(cddr place))) ,valsym
                       ,@body))
                ;; 0 elements, we already implemented that
                `(fn* nil ,@body))
            (eq (car place) 'quote)
              ;; Require equality
              `(fn (,valsym)
                 (assert (eq ,valsym ,place) "Failed to match ~s to ~s (~s)." ,valsym ,place ',place)
                 ,@body)
            t
              (error "Unknown fn*-place: ~a" (car place))))
      t
        (error "Unknown fn*-place ~s" place)))

  (mac let* (place val . body)
    `((fn* ,place ,@body)
      ,val))

  (mac matchor cases
    (cond (null cases)
            (error "(matchor) is illegal.")
          ;; Single case
          (null (cdr cases))
            (car cases)
          ;; Multiple cases
          t
            (with-gensyms k
              `(call/cc
                 (fn (k)
                   (let matchfail (fn _ (matchor ,@(cdr cases)))
                     ,(car cases)))))))

  )