多値のスタックでFORTHの真似事 — #:g1

Posted 2012-05-19 13:09:00 GMT

gforthのチュートリアルをちょっとやってみてforthも面白いなと思ったのですが、CLでスタックといえば多値が身近じゃないか、ということで、遊んでみました。
ポーランドと逆ポーランドを行ったり来たりで混乱しますが、引数の扱いをもうちょっとすっきりさせて、曖昧さを無くせれば、括弧を省略してひっくりかえして書けるかもしれません。

;;; multiple-value-callが長いので #[]と省略して書く
(set-dispatch-macro-character #\# #\[
                              (lambda (s c a)
                                (declare (cl:ignore a c))
                                (destructuring-bind (fn . args)
                                                    (read-delimited-list #\] s t)
                                  `(multiple-value-call
                                     #',fn
                                     ,@args))))

(defun drop (&rest args) (declare (dynamic-extent args)) (values-list (cdr args)))

#[drop 1 2 3 4 5] ;=> 2 ; 3 ; 4 ; 5

(defun nip (&rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (car args) (values-list (cddr args))))

#[nip 1 2 3 4 5] ;=> 1 ; 3 ; 4 ; 5

(defun swap (x y &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values y x (values-list args)))

#[swap 1 2 3 4 5] ;=> 2 ; 1 ; 3 ; 4 ; 5

(defun over (&rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (second args) (values-list args)))

#[over 1 2 3 4 5] ;=> 2 ; 1 ; 2 ; 3 ; 4 ; 5

(defun tuck (x y &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values x y x (values-list args)))

#[tuck 1 2 3 4 5] ;=> 1 ; 2 ; 1 ; 3 ; 4 ; 5

(defun vmod (x y &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (cl:rem y x) (values-list args)))

#[vmod 7 4 :a :b :c] ;=> 3 ; :A ; :B ; :C

(defun dup (&rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (first args) (values-list args)))

#[dup 1 2 3 4 5] ;=> 1 ; 1 ; 2 ; 3 ; 4 ; 5

(defun 0= (x &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (if (zerop x) -1 0) (values-list args)))

#[0= 0 1 2 3 5] ;=> -1 ; 1 ; 2 ; 3 ; 5

(defun until (mvfn &rest args) (declare (dynamic-extent args)) (labels ((*until (&rest args) (declare (dynamic-extent args)) (multiple-value-call (lambda (true? &rest args) (if (= -1 true?) (values-list args) (multiple-value-call #'*until (values-list args)))) (apply mvfn args)))) (apply #'*until args)))

#[until (lambda (cnt &rest args) #[dup #[values (1- cnt) (values-list args)]]) 5 :a :b :c] ;=> -1 ; :A ; :B ; :C

;; : gcd ( u1 u2 ) ;; begin ;; tuck mod ;; dup 0= ;; until ;; drop ;

(defun my-gcd (x y &rest args) (declare (dynamic-extent args)) #[drop #[until (lambda (x y) #[0= #[dup #[vmod #[tuck x y]]]]) x y] (values-list args)])

(multiple-value-call #'my-gcd 1029 1071 :a :b :c) ;=> 21 ; :A ; :B ; :C

comments powered by Disqus