Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2007-07-31

.17

| 21:22 | .17 - わだばLisperになる を含むブックマーク はてなブックマーク - .17 - わだばLisperになる

日課練習、SRFI-1 assoc系書き散らかし。

(defun alist-copy (alist)
  (mapcar (lambda (x) (cons (car x) (cdr x))) alist))

(defun alist-copy (alist)
  (prog (al result)
        (setq al alist)
    L	(cond ((endp al) (return (nreverse result))))
	(push (cons (caar al) (cdar al)) result)
	(pop al)
	(go L)))

(defun alist-copy (alist)
  (let (result)
    (dolist (l alist (nreverse result))
      (push (cons (car l) (cdr l)) result))))

(defun alist-copy (alist)
  (let (result)
    (mapc (lambda (item) 
	    (push (cons (car item) (cdr item)) result))
	  alist)
    (nreverse result)))

(defun alist-delete (key alist &optional (elt= #'equal))
  (let (result)
    (mapc (lambda (item) 
	    (and (funcall elt= key (car item))
		 (push item result)))
	    alist)
    result))

(defun alist-delete (key alist &optional (elt= #'equal))
  (do ((al alist (cdr al))
       (result))
      ((endp al) (nreverse result))
    (and (funcall elt= key (caar al)) (push (car al) result))))

(defun alist-delete (key alist &optional (elt= #'equal))
  (let (result)
    (dolist (al alist (nreverse result))
      (and (funcall elt= key (car al)) (push al result)))))

(defun alist-delete (key alist &optional (elt= #'equal))
  (reduce (lambda (r x) 
	    (if (funcall elt= key (car x))
		(cons x r)
		r))
	  alist
	  :initial-value '() ))

(defun alist-delete! (key alist &optional (elt= #'equal))
  (mapcan (lambda (item) (and (funcall elt= key (car item)) `(,item)))
	  alist))

2007-07-29

つくりましょう.16

17:30 | つくりましょう.16 - わだばLisperになる を含むブックマーク はてなブックマーク - つくりましょう.16 - わだばLisperになる

日課練習、SRFI-1 assoc系。 適当に

(defun assq (key alist)
  (assoc key alist :test #'eq))

(defun assv (key alist)
  (assoc key alist :test #'eql))

(defun alist-cons (key datum alist)
  (cons (cons key datum) alist))

2007-07-28

.15

| 18:45 | .15 - わだばLisperになる を含むブックマーク はてなブックマーク - .15 - わだばLisperになる

日課練習、SRFI-1 find、find-tail 簡単なものを作る

のが好きだー。

(defun srfi-find (pred clist)
  (find-if pred clist))

(defun srfi-find (pred clist)
  (do ((l clist (cdr l)))
      ((null l) nil)
    (and (funcall pred (car l))
	 (return (car l)))))

(defun srfi-find (pred clist)
  (prog nil
    L   (cond ((null clist) (return nil)))
	(and (funcall pred (car clist)) (return (car clist)))
	(pop clist)
	(go L)))

(defun srfi-find (pred clist)
  (dolist (l clist nil)
    (and (funcall pred l) (return l))))

(defun srfi-find (pred clist)
  (prog nil
    (mapc (lambda (x) (and (funcall pred x) (return x))) 
	  clist)))

(defun srfi-find (pred clist)
  (block nil
    (mapc (lambda (x) 
	    (and (funcall pred x) (return x))) 
	  clist)))

;; ================================================================
(defun find-tail (pred clist)
  (prog nil
    L   (cond ((null clist) (return nil)))
	(and (funcall pred (car clist)) (return clist))
	(pop clist)
	(go L)))

(defun find-tail (pred clist)
  (prog nil
        (mapl #'(lambda (x)
		  (and (funcall pred (car x)) (return x)))
	      clist)))

(defun find-tail (pred clist)
  (block nil
    (mapl #'(lambda (x) 
	      (and (funcall pred (car x)) (return x)))
	  clist)))

(defun find-tail (pred clist)
  (do ((l clist (cdr l)))
      ((null l) nil)
    (and (funcall pred (car l)) (return l))))

(defun find-tail (pred clist)
  (loop for l on clist 
        do (when (funcall pred (car l)) (return l))))

2007-07-27

.14

| 00:37 | .14 - わだばLisperになる を含むブックマーク はてなブックマーク - .14 - わだばLisperになる

日課練習、SRFI-1 unfold

(defun unfold (p f g seed &optional (tail-gen #'(lambda (x) (declare (ignore x)) '())))
  (if (funcall p seed)
      (funcall tail-gen seed)
      (cons (funcall f seed)
	    (unfold p f g (funcall g seed) tail-gen))))

(defun unfold (p f g seed &optional (tail-gen #'(lambda (x) (declare (ignore x)) '())))
  (do ((seed seed (funcall g seed))
       (result '() (cons (funcall f seed) result)))
      ((funcall p seed) (nreconc result (funcall tail-gen seed)))))

(defun unfold (p f g seed &optional (tail-gen #'(lambda (x) (declare (ignore x)) '())))
  (do* ((s seed (funcall g s))
	(result (list s))
	(splice result (cdr (rplacd splice (list (funcall f s))))))
       ((funcall p s) (append result (funcall tail-gen s)))))

2007-07-26

.13

| 00:02 | .13 - わだばLisperになる を含むブックマーク はてなブックマーク - .13 - わだばLisperになる

日課練習、SRFI-1 lset系。

(defun lset-union (elt= &rest lists)
  (do ((l (reverse lists) (cdr l))
       (result '() (apply #'lset-adjoin elt= (car l) result)))
      ((null l) result)))

(defun lset-union (elt= &rest lists)
  (prog (result)
    L   (cond ((null lists) (return result)))
	(setq result (apply #'lset-adjoin elt= (pop lists) result))
	(go L)))

(defun lset-union (elt= &rest lists)
  (labels ((frob (elt= lists result)
	     (if (null lists)
		 result
		 (frob elt= 
		       (cdr lists)
		       (apply #'lset-adjoin elt= (car lists) result)))))
    (frob elt= (reverse lists) '() )))

;; ================================================================
(defun lset-adjoin (elt= list &rest elts)
  (if (functionp elt=)
      (reduce #'(lambda (retlst elt) (adjoin elt retlst :test elt=))
	      elts
	      :initial-value list)
      (error "bad type of argument for =")))

2007-07-25

.12

| 00:28 | .12 - わだばLisperになる を含むブックマーク はてなブックマーク - .12 - わだばLisperになる

日課練習、SRFI-1細かいの色々。

*print-circle*はtのこころ。

;; ================================================================
(defun zip (&rest clists)
  (apply #'mapcar #'list clists))

;; ================================================================
(defun length+ (list)
  (and (proper-list? list)
       (list-length list)))

;; ================================================================
(defun proper-list? (x)
  (and (listp x)
       (not (circular-list? x))
       (null (cdr (last x)))))

;; ================================================================
(defun null-list? (x)
  (and (or (proper-list? x)
	   (circular-list? x)
	   (error "*** ERROR: argument must be a list, but got: ~S" x))
       (null x)))

;; ================================================================
(defun dotted-list? (x)
  (and (listp x)
       (not (circular-list? x))
       (not (null (cdr (last x))))))

;; ================================================================
(defun circular-list? (lst)
  (and (consp lst)
       (not (atom (cdr lst)))
       (cddr lst)
       (prog (x y)
             (setq x (cdr lst))
	     (setq y (cddr lst))
          l  (cond ((null x) (return nil))
		   ((eq x y) (return t)))
	     (setq x (cdr x))
	     (setq y (cddr y))
	     (go l))))

;; ================================================================
(defun null? (x)
  (null x))

;; ================================================================
(defun pair? (x)
  (consp x))

;; ================================================================
(defun not-pair? (x)
  (not (consp x)))

2007-07-22

.11

| 10:38 | .11 - わだばLisperになる を含むブックマーク はてなブックマーク - .11 - わだばLisperになる

日課練習、append-map!、map!

append-mapって結局mapcanのことなんだろうか。

リストの破壊的操作の理解がいまいち足りない。

(defun append-map! (f &rest clists)
  (apply #'mapcan f clists))

(defmacro append-map! (f &body clists)
  `(mapcan ,f ,@clists))

(defun map! (f &rest clists)
  (apply #'mapcar f clists))

(defun map! (f &rest clists)
  (do ((l clists (mapcar #'cdr l))
       (result '() (cons (apply f (mapcar #'car l)) result)))
      ((some #'null l) (nreverse result))))

2007-07-21

.10

| 22:58 | .10 - わだばLisperになる を含むブックマーク はてなブックマーク - .10 - わだばLisperになる

日課練習、日課練習、日課練習、append-map

(defun append-map (f &rest clists)
  (apply #'append (apply #'mapcar f clists)))

(defun append-map (f &rest clists)
  (prog (result)
    L   (cond ((some #'endp clists) (return (apply #'append (nreverse result)))))
        (push (apply f (mapcar #'car clists)) result)
        (setq clists (mapcar #'cdr clists))
        (go L)))

(defun append-map (f &rest clists)
  (prog (result splice)
        (setq result (apply f (mapcar #'car clists)))
        (setq splice result)
    L   (setq clists (mapcar #'cdr clists))
        (cond ((some #'null clists) (return result)))
        (setq splice (last (rplacd (last splice) (apply f (mapcar #'car clists)))))
        (go L)))

(defun append-map (f &rest clists)
  (let ((result (apply f (mapcar #'car clists))))
    (do ((l (mapcar #'cdr clists) (mapcar #'cdr l))
	 (splice result (last (rplacd (last splice) (apply f (mapcar #'car l))))))
	((some #'null l) result))))

2007-07-20

.9

| 13:05 | .9 - わだばLisperになる を含むブックマーク はてなブックマーク - .9 - わだばLisperになる

日課練習、日課練習、日課練習、unfold-right

(defun unfold-right (p f g seed &optional tail)
  (do ((seed seed (funcall g seed))
       (lis tail (cons (funcall f seed) lis)))
      ((funcall p seed) lis)))

(defun unfold-right (p f g seed &optional tail)
  (prog nil
    L   (cond ((funcall p seed) (return tail)))
    	(setq tail (cons (funcall f seed) tail))
	(setq seed (funcall g seed))
	(go L)))

(defun unfold-right (p f g seed &optional tail)
  (prog nil
    L   (cond ((funcall p seed) (return tail)))
    	(psetq seed (funcall g seed)
	       tail (cons (funcall f seed) tail))
	(go L)))

(defun unfold-right (p f g seed &optional tail)
  (prog nil
    L   (cond ((funcall p seed) (return tail)))
    	(setq tail 
	      (cons (funcall f (prog2 nil seed (setq seed (funcall g seed)))) 
		    tail))
	(go L)))

2007-07-19

CADRエミュレータ (4) Lispの開発環境

| 23:09 | CADRエミュレータ (4) Lispの開発環境 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRエミュレータ (4) Lispの開発環境 - わだばLisperになる

とりあえず、外部とのファイルのやりとりもできるようになりました。

折角のLispマシンなので、Lispを書いて遊びたいところだと思うので、CADRのLisp開発環境について書きたいと思います。

この辺からは、自分がLispの開発の経験がある訳でもなくLisp自体に詳しい訳でもないので、詳しいことは全く分かりませんので、かなり適当なことを書いている可能性も高いですが、とりあえず、自分が遊んでみたところを書いてみたいと思います。

コードを書く

これはZmacs上でEmacsと同じ感覚でファイル作成/編集ができます。Emacs上でのLispコードの操作ということに関しては、70年代のITS Emacs、Zmacsの時点でほぼ完成しているということなのかもしれません。

インタラクティブに書きたいんじゃ

これは、編集中のコードを評価することによってEmacsのinferior lisp modeの様な感覚でコードを書くことができるかと思います。評価された結果は、エコーエリアに表示されます。

Eval Defun (Control-Shift-E (Control-Hyper-E))

で、式を評価、

Compile Defun (Control-Shift-C (Control-Hyper-C))

で、式をコンパイルのようです。

評価した結果にエラーがある場合は、デバッガが起動します。デバッガから抜けるには、C-zを押します。

という感じで、自分などは、大したものを書く訳でもなく、書けるわけでもないので、エディタ上から式が評価できるだけで十分遊べます。

ヘルプ

とりあえずのところとしては、

Documentation (Control-Meta-?)

があります。

Control-Meta-?を押して実行すると、

Doc A,C,D,L,V,W,<space>,?:

となるので、適宜調べたい内容に応じてキーを選択します。

AとspaceはAproposの実行 (Emacsでもapropos)

Cは、Document Command (Emacsでのdescribe-key)

D、Describe Command (Emacsでのdescribe-function)

L、詳細不明です。

V、Variable 変数のApropos

W、Where Is / どのキーコンビネーションに割り当てられているか

という感じです。

他にも、M-.等々Emacsでもお馴染の機能があるので、試してみると面白いかと思います。

2007-07-16

CADRエミュレータ (3) ホスト上のファイルを読み書きする

| 23:08 | CADRエミュレータ (3) ホスト上のファイルを読み書きする - わだばLisperになる を含むブックマーク はてなブックマーク - CADRエミュレータ (3) ホスト上のファイルを読み書きする - わだばLisperになる

CADRエミュレータは単体でも遊べますが、作成したファイルなどをエミュレータ外部に持ち出せるとより楽しく遊べます。

サーバの導入

エミュレータの配布サイトでは、Linux上で動くCADR用のファイルサーバ?がありますので、ダウンロードして設置します。

Retrocomputing - MIT CADR Lisp Machines:

http://www.unlambda.com/cadr/index.html

のページのChaosnet server tar fileをダウンロードしuntarします。

展開されたchaosdというディレクトリの中にコンパイル済みのLinux用のバイナリがありますので、

./chaos

./server

の順で起動させます。

起動は、展開ずみのディレクトリにcdして実行する必要があるようです。

(自分は、毎回起動が面倒なので、シェルスクリプトにして実行しています。)

サーバが起動された状態で、usimを起動し、CADRから接続を試みます。

配布されている状態では、アドレスは設定済みになっていますので、サイトの例と同じく、CADRエミュレータより、

(login 'foo t)
(si:set-sys-host "server" ':unix 0404 "//")

と実行し、CADRにログインした後にサーバと接続します。

ホスト上のファイルの読み書き

ホスト上のファイル名ですが、server://foo//bar//baz.quuxの様になります。

"/"が二重になっていますが、"/"はCADRではエスケープキャラクタとなっているので、二重に表現する必要があります。

読み書き時の初回時には、接続のため、ユーザ名とパスワードを尋ねてきますので、ホストでのユーザ名 <スペース> そのユーザのパスワードを入力します。

以上、ホスト上のファイルの読み書きについて書いてみました。

(si:set-sys-host "server" ':unix 0404 "//")

等々は、一々入力するのも面倒です。

自分は、スクラッチファイルを適当に容易して、Zmacs上から式をEvaluate Defun(Control-Hyper-E、どういう訳かエミュレータではC-Sh-Eを押すとこの組み合わせが発生)で評価してみていますが、楽ができるので結構お勧めです。

.8

| 11:02 | .8 - わだばLisperになる を含むブックマーク はてなブックマーク - .8 - わだばLisperになる

日課練習、日課練習

SRFI-1のfold-rightを作ってみた。

ややこしい。というか、ちゃんとできてるのか疑問。

(defun fold-right (kons knil &rest clists)
  (do ((pairs
        (do ((ls clists (mapcar #'cdr ls))
             (r '() (cons (mapcar #'car ls) r)))
            ((some #'endp ls) r))
        (cdr pairs))
       (r knil (apply kons `(,@(car pairs) ,r))))
      ((endp pairs) r)))

(defun fold-right (kons knil &rest clists)
  (prog (r pairs)
        (setq r knil)
    a   (cond ((some #'endp clists) (go b)))
        (push (mapcar #'car clists) pairs)
        (setq clists (mapcar #'cdr clists))
        (go a)
    b   (cond ((endp pairs) (return r)))
        (setq r (apply kons `(,@(car pairs) ,r)))
        (pop pairs)
        (go b)))

2007-07-14

CADRエミュレータ (2) ユーザ環境設定編

| 23:08 | CADRエミュレータ (2) ユーザ環境設定編 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRエミュレータ (2) ユーザ環境設定編 - わだばLisperになる

CADRはシングルユーザシステムですが、ユーザ毎に環境を設定して切り換えて使用することはできます。

(login 'foo)

とすることで、ユーザfooでログインできます。

何らかの理由で、環境設定初期化ファイルを読み込ませたくない場合は、

(login 'foo t)

とします。

(logout)

でログアウトします。

ホームディレクトリの作成

fooでログインした場合、ホームディレクトリfooにある。lispm.initを読み込み実行します。

恐らくホームディレクトリの場所の指定は様々あると思うのですが、良く分からないので、とりあえず、ホームディレクトリを作成し、その中にlispm.initを作成することによってユーザ環境を設定する方法を書きます。

とりあえず、ログインして作業を開始します。

(login 'foo t)

として、初期化ファイルを読み込まずログインし、F2 f(F2キーのあとで、Fを押す)とFile System Editorが起動するので、Tree edit rootを左クリック。しばし待ち、

>*.*.*

の上で右クリック。(ディレクトリのパスセパレータは、">"です)

Directory operationsメニューが表示されるので、Create Inferior Directoryを選択

名前の入力を促されるので、ユーザIDと同じ名前を入力するとディレクトリが作成されます。

初期化ファイルの作成

ホームディレクトリが作成されたので、ユーザの初期化ファイルを作成してみます。

一旦

(logout)

でログアウトし、

(login 'foo)

でログインし直します。

(ed)

と入力すると、Zmacs(Lisp Machine版のEmacs)が起動します。

ホームディレクトリにいるので、Emacsと同様に、C-x C-fとし、lispm.initを作成します。

初期化ファイルについては情報が少なく詳細は不明ですが、自分が適当に探って作成してみたものを置いてみます。

ウェブから入手できる初期化ファイルとしては、http://www.unlambda.com/lisp/mit.page

で配布されているファイルの中に、David Moon氏の初期化ファイルがあります。(moon/moon.lispm)

自分もそれを参考に作成してみました。

※αとなっている場所は、制御文字^Bで、εは、^Fです。

入力に関しては、Emacsと同様に^Q^B等で入力できます。

;-*- Mode:LISP; Package:USER; Base:8.-*-

(login-setq base 10.			; 表示用の基数を10進数に設定
	    ibase 10.			; 入力用の基数を10進数に設定
	    user-id "g000001")		; ユーザID

;; キーバインドのカスタマイズ
(login-eval zwei:(set-comtab-return-undo *standard-comtab* 
					 '(#α/m com-insert-crs         ; C-mとReturnとで同じ振舞い
					   #α/i com-indent-for-lisp    ; C-iとタブとで同じ振舞い
					   #α/h com-tab-hacking-rubout ; C-hでRubout(Backspace)
					   #ε\sp com-just-one-space))) ; C-M-Spaceで、Just one Space
(login-eval zwei:(set-comtab-return-undo *completing-reader-comtab* 
					 '(#α/m com-complete-and-exit))) ; エコーエリア?でもC-mが使えるようにしてみる(中途半端)

;;
(ed ">g000001>gazonk.del")                   ; ログインするとすぐZmacsが起動

.7

| 10:43 | .7 - わだばLisperになる を含むブックマーク はてなブックマーク - .7 - わだばLisperになる

日課練習的に毎日作っていきたいところ。

SRFI-1のfoldを作ってみた。

開発環境: Slime/SBCL Linux

(defun fold (kons knil &amp;rest clists)
  (do ((ls clists (mapcar #'cdr ls))
       (r knil (apply kons `(,@(mapcar #'car ls) ,r))))
      ((some #'endp ls) r)))

(defun fold (kons knil &amp;rest clists)
  (prog (r)
        (setq r knil)
    l   (cond ((some #'endp clists) (return r)))
	(setq r (apply kons `(,@(mapcar #'car clists) ,r)))
	(setq clists (mapcar #'cdr clists))
	(go l)))

(defun fold (kons knil &amp;rest clists)
  (labels ((frob (kons knil clists)
	     (if (some #'endp clists)
		 knil
		 (frob kons 
		       (apply kons `(,@(mapcar #'car clists) ,knil)) 
		       (mapcar #'cdr clists)))))
    (frob kons knil clists)))

2007-07-13

CADRエミュレータ (1) デモ編

| 23:07 | CADRエミュレータ (1) デモ編 - わだばLisperになる を含むブックマーク はてなブックマーク - CADRエミュレータ (1) デモ編 - わだばLisperになる

CADRエミュレータについては、分かりやすい導入の手引があります。

A quick first tour of the CADR lispm using usim

http://labs.aezenix.com/lispm/index.php?title=CADR_First_Tour

ここのサイトさんにはlispm関係の情報が色々まとまってるんですが、スパムがひどいみたいで、現在フロントページから内容が俯瞰できない様子です。

動作するプラットホームとしては、Windows、MacOSX、Linux等がありますが、Linuxがメインの開発プラットホームの様子で、ホストと通信してファイルを読み書きできたりもするので個人的にはLinuxがお勧めです。

手引の中で、

 (hacks:worm)

とありますが、この方法以外にもリスナーで

(demo)

と実行すると、デモを選択するプログラムが起動し、色んなデモプログラムが選択できるのでお勧めです…が良く固まる気もします…。

最初の起動では、かなり長く待たされたと思いますが、これを短縮する、ウォームブートという起動方法があります。詳細は、READMEに解説されていますが、手順としては、

./usim -S

で起動し、日付を入力するところまで完了させ、ターミナル上で、^Cを二回押しエミュレータを終了させます。するとusim.stateというファイルができ、これに状態が記録されているので、次回以降、

./usim -w

と入力することによって、さっと起動できるようになります。

2007-07-12

.1

| 23:06 | .1 - わだばLisperになる を含むブックマーク はてなブックマーク - .1 - わだばLisperになる

前回リスプマシン(以下lispm)のCADRエミュレータについて書きましたが、CADRエミュレータについては情報も少ないようなので、分からないながらも、自分が試してみたことや、lispmエミュレータの近況を自分つらつらと、単発的かつ断片的に書いてみることにしました。

まず、どんなものがあるのか

MIT - CADR

元祖lispmです。

http://www.unlambda.com/cadr/

TI - Explorer

テキサス・インスツルメンツが開発していたlispmです。

Meroko:

http://www.unlambda.com/lisp/meroko.page

Symbolics - VLM

SymbolicsがDEC Alpha用の仮想マシンとして開発したものです。

CADRエミュレータ作者のBrad Parker氏によってLinuxに移植が試みられている様子です。

VLM On Linux

http://labs.aezenix.com/lispm/index.php?title=VLM_On_Linux

XEROX - Interlisp-D

Interlisp系のlispmである、Interlisp-Dの仮想マシン

です。

http://sumim.no-ip.com:8080/collab/76

に詳しい情報があります。

NTT - TAO/ELIS

TAO/ELIS の UNIX への移植/天海良治」という論文もありFreeBSDに移植されているようです。

2007-07-06


.6

| 23:05 | .6 - わだばLisperになる を含むブックマーク はてなブックマーク - .6 - わだばLisperになる

今日はレトロにsrfi-1のunzip~をLisp Machine Lispで作ってみたり。

Lisp machine lispとは、Maclisp~Common Lispの中間の時代に位置するLispで、MITのLispマシンで動いていたらしいとの噂。

SymbolicsのLispマシンで動くものは、Zetalispと呼ばれているという印象。

システム全体をLispで記述できるようにLisp Machine Lispのを強化したものの様子、という感想。

1970年代後半位のLispマシンのエミュレータがあるので、動かしてみると楽しいです。

http://www.unlambda.com/cadr/

;; Lisp machine Lisp

(defun unzip1 (lists)
  (unzip* lists 1))

(defun unzip2 (lists)
  (unzip* lists 2))

(defun unzip3 (lists)
  (unzip* lists 3))

(defun unzip4 (lists)
  (unzip* lists 4))

(defun unzip5 (lists)
  (unzip* lists 5))

(deff consp #'listp)

(defun scheme-car (list)
  (cond ((consp list) (car list))
	('T (ferror nil "pair required, but got ~S" list))))

(defun unzip* (lists i)
  (prog (l r cnt)
        (setq l lists)
	(setq cnt i)
     l	(cond ((zerop cnt) (return (apply #'values (nreverse r)))))
	(push (mapcar #'scheme-car l) r)
	(setq l (mapcar #'cdr l))
	(decf cnt)
	(go l)))