Name: Anonymous 2013-03-22 19:18
Help me refactoring following funcion. It was growing and growing, and now I can barely navigate across it.
(defun merge-lambs (name ls)
(let* ((a (unisym))
(ms (make-hash-table :test 'equal)) ; methods
(mm nil) ; multimethod
(vars nil) ; object variables
(w (unisym)) ; wild
(wild nil)
(h (unisym))
(init (unisym))
(vs nil)
(close (has-arrow? (rhd ls)))
(used-vars (make-hash-table :test 'equal))
)
(unless close (setf name nil))
($map (fn (l)
(setf l ($split #'arrow? l))
(when (> (len l) 1)
(setf l (lst (1st l)
(fold (2nd l)
(fn (a b) (st ($$a $"|" $$b)))
(drop 2 l)))))
(if (< (len l) 2)
(let ((x (lhd l)))
(setf l (if (equal (2nd x) ":")
(st ($(lhd x) $(drop 2 x)))
(st ($nil $x))))
(let ((x (lhd l)))
(cond ((stringp x)
(if (gethash x used-vars)
(error "redeclaration of `~a`" X)
(setf (gethash x used-vars) t)))
((unesc? x) (setf l (st ($nil $(expand-set (2nd x) (2nd l))))))
))
(setf (gethash "Var" ms) (st ($$(gethash "Var" ms) $l)))
)
(let* ((l (st ($(lhd l) (_ do $$(ltl l)))))
(hd (lhd (lhd l)))
(n hd))
(if (fn-sym? hd)
(setf l (st ($(ltl (lhd l)) $$(ltl l))))
(setf n "?"))
(setf l (st ((|[]| $(lhd l)) $$(ltl l))))
(setf (gethash n ms) (st ($l $$(gethash n ms)))))
)
nil)
ls)
(setf vars (gethash "Var" ms))
(remhash "Var" ms)
(maphash (fn (hd ls)
;;(setf ls (rev ls))
(let* ((x (chain-lambs a ls nil))
(*checked-lst-method* (if (string= hd "?") nil hd))
(y (when *checked-lst-method*
(chain-lambs a ls nil))))
(setf (gethash hd ms) (cons x y))))
ms)
(setf wild (car (gethash "?" ms)))
(remhash "?" ms)
(maphash (fn (k v) (setf vs (st (($k $(cdr v) (_ fn ($a) $(car v))) $$vs))))
ms)
(setf mm (if (= (hash-table-count ms) 0)
wild
(st (_ let (($w (_ fn () $wild)) ($h (_ host (aref $a 0))))
(_ if (_ host (stringp $h))
$(search-method h ($map #'rtl vs) (st (_ host (topject (|@| $name) $a))))
(_ host (funcall $w)))))))
(when name (setf mm (st (_ host (block $name ($"@" $mm))))))
(setf mm (st (_ fn ($a) $mm)))
(when name (setf mm (st (_ name $name $mm))))
(when vars
(let ((vi (st (_ do $$($map (fn (v) (if (1st v)
(st (_ set $$v))
(2nd v)))
vars)))))
(setf mm (if close
(st (_ do (_ set $init (_ fn $(when name (lst name))
$vi))
$mm))
vi))))
(unless (= (hash-table-count ms) 0)
(setf mm (st (_ let ($$($map (fn (v) (lst (lhd v) nil)) vs))
(_ do $$($map (fn (v) (st (_ set $(1st v) $(3rd v)))) vs)
$mm)))))
(let ((vars (keep #'1st vars)))
(when vars
(setf mm (st (_ let $($map (fn (v) (st ($(1st v) n))) vars)
$mm)))))
(when name
(setf mm (st (_ let (($name $nil))
(_ do (_ set $name $mm)
$name)))))
(when (and vars close)
;; generate call to init closure
(let ((tmp (unisym)))
(setf mm (st (_ let (($init $nil))
(_ let (($tmp $mm))
(_ do (_ host (funcall $init $$(when name (lst tmp))))
$tmp)))))))
mm))
(defun merge-lambs (name ls)
(let* ((a (unisym))
(ms (make-hash-table :test 'equal)) ; methods
(mm nil) ; multimethod
(vars nil) ; object variables
(w (unisym)) ; wild
(wild nil)
(h (unisym))
(init (unisym))
(vs nil)
(close (has-arrow? (rhd ls)))
(used-vars (make-hash-table :test 'equal))
)
(unless close (setf name nil))
($map (fn (l)
(setf l ($split #'arrow? l))
(when (> (len l) 1)
(setf l (lst (1st l)
(fold (2nd l)
(fn (a b) (st ($$a $"|" $$b)))
(drop 2 l)))))
(if (< (len l) 2)
(let ((x (lhd l)))
(setf l (if (equal (2nd x) ":")
(st ($(lhd x) $(drop 2 x)))
(st ($nil $x))))
(let ((x (lhd l)))
(cond ((stringp x)
(if (gethash x used-vars)
(error "redeclaration of `~a`" X)
(setf (gethash x used-vars) t)))
((unesc? x) (setf l (st ($nil $(expand-set (2nd x) (2nd l))))))
))
(setf (gethash "Var" ms) (st ($$(gethash "Var" ms) $l)))
)
(let* ((l (st ($(lhd l) (_ do $$(ltl l)))))
(hd (lhd (lhd l)))
(n hd))
(if (fn-sym? hd)
(setf l (st ($(ltl (lhd l)) $$(ltl l))))
(setf n "?"))
(setf l (st ((|[]| $(lhd l)) $$(ltl l))))
(setf (gethash n ms) (st ($l $$(gethash n ms)))))
)
nil)
ls)
(setf vars (gethash "Var" ms))
(remhash "Var" ms)
(maphash (fn (hd ls)
;;(setf ls (rev ls))
(let* ((x (chain-lambs a ls nil))
(*checked-lst-method* (if (string= hd "?") nil hd))
(y (when *checked-lst-method*
(chain-lambs a ls nil))))
(setf (gethash hd ms) (cons x y))))
ms)
(setf wild (car (gethash "?" ms)))
(remhash "?" ms)
(maphash (fn (k v) (setf vs (st (($k $(cdr v) (_ fn ($a) $(car v))) $$vs))))
ms)
(setf mm (if (= (hash-table-count ms) 0)
wild
(st (_ let (($w (_ fn () $wild)) ($h (_ host (aref $a 0))))
(_ if (_ host (stringp $h))
$(search-method h ($map #'rtl vs) (st (_ host (topject (|@| $name) $a))))
(_ host (funcall $w)))))))
(when name (setf mm (st (_ host (block $name ($"@" $mm))))))
(setf mm (st (_ fn ($a) $mm)))
(when name (setf mm (st (_ name $name $mm))))
(when vars
(let ((vi (st (_ do $$($map (fn (v) (if (1st v)
(st (_ set $$v))
(2nd v)))
vars)))))
(setf mm (if close
(st (_ do (_ set $init (_ fn $(when name (lst name))
$vi))
$mm))
vi))))
(unless (= (hash-table-count ms) 0)
(setf mm (st (_ let ($$($map (fn (v) (lst (lhd v) nil)) vs))
(_ do $$($map (fn (v) (st (_ set $(1st v) $(3rd v)))) vs)
$mm)))))
(let ((vars (keep #'1st vars)))
(when vars
(setf mm (st (_ let $($map (fn (v) (st ($(1st v) n))) vars)
$mm)))))
(when name
(setf mm (st (_ let (($name $nil))
(_ do (_ set $name $mm)
$name)))))
(when (and vars close)
;; generate call to init closure
(let ((tmp (unisym)))
(setf mm (st (_ let (($init $nil))
(_ let (($tmp $mm))
(_ do (_ host (funcall $init $$(when name (lst tmp))))
$tmp)))))))
mm))