```<div class="document" id="wang"
title="Old LISP programs still run in Common Lisp"
description="Old LISP program running in Common Lisp"
author="Pascal J. Bourguignon"
keywords="LISP 1.5, Common Lisp, Lisp, Wang algorithm"
language="en">

<h1>Old LISP programs still run in Common Lisp</h1>

<p>Actually, any Common Lisp implementation can be applied with
almost all Lisp material from any time, thanks to the concensual
approach of the Common Lisp standard.</p>

<p>For example, here is how you can run a lisp program written in
1960 in a Common Lisp of 2014.  Rendez-vous in 28 years to see
how you can run a 1996 perl program in perl 2042...</p>

<p>This Wang's algorithm has been popularized by John McCarthy as an
application of LISP, published in the manual of the first version
<a href="http://community.computerhistory.org/scc/projects/LISP/book/LISP%20I%20Programmers%20Manual.pdf">LISP 1 Programmer's Manual, page 32</a>
(and also reproduced in
<a href="http://community.computerhistory.org/scc/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf#page=52">LISP
1.5 Programmer's Manual, Chapter VIII, page 52: A Complete LISP
Program - the Wang Algorithm for the Propositional
Calculus.</a>). </p>

<pre class="code">
----(wang-cl.lisp)------------------------------------------------------
(defun trace   (functions) (eval `(cl:trace   ,@functions)))
(defun untrace (functions) (eval `(cl:untrace ,@functions)))

(defun define (definitions)
(dolist (def definitions)
(eval (if (and (consp (second def)) (eq 'lambda (car (second def))))
`(progn (defun        ,(first def) ,@(cdr (second def)))
(defparameter ,(first def) ,(second def)))
`(defparameter ,(first def) ,(second def))))))

(defun stop (arguments) (throw 'driver-end-of-deck nil))
(defun fin  (arguments) (throw 'driver-end-of-deck nil))
(defun test (arguments) (princ arguments) (terpri))

(defun driver (path)
(with-open-file (cards path)
(catch 'driver-end-of-deck
(if (char= #\* first-char)
(progn
(arguments (if (member command '(stop fin test))
(print (apply command arguments))))))))))

(driver "wang.job")
----(wang.job)----------------------------------------------------------
* M948-1207 LEVIN, LISP, TEST, 2,3,250,0
TEST WANG ALGORITHM FOR THE PROPOSITIONAL CALCULUS

DEFINE ((

(TH1 (LAMBDA (A1 A2 A C) (COND ((NULL A)
(TH2 A1 A2 NIL NIL C)) (T
(OR (MEMBER (CAR A) C) (COND ((ATOM (CAR A))
(TH1 (COND ((MEMBER (CAR A) A1) A1)
(T (CONS (CAR A) A1))) A2 (CDR A) C))
(T (TH1 A1 (COND ((MEMBER (CAR A) A2) A2)
(T (CONS (CAR A) A2))) (CDR A) C))))))))

(TH2 (LAMBDA (A1 A2 C1 C2 C) (COND
((NULL C) (TH A1 A2 C1 C2))
((ATOM (CAR C)) (TH2 A1 A2 (COND
((MEMBER (CAR C) C1) C1) (T
(CONS (CAR C) C1))) C2 (CDR C)))
(T (TH2 A1 A2 C1 (COND ((MEMBER
(CAR C) C2) C2) (T (CONS (CAR C) C2)))
(CDR C))))))

(TH (LAMBDA (A1 A2 C1 C2) (COND ((NULL A2) (AND (NOT (NULL C2))
(THR (CAR C2) A1 A2 C1 (CDR C2)))) (T (THL (CAR A2) A1 (CDR A2)
C1 C2)))))

(THL (LAMBDA (U A1 A2 C1 C2) (COND
((EQ (CAR U) (QUOTE NOT)) (TH1R (CADR U) A1 A2 C1 C2))
((EQ (CAR U) (QUOTE AND)) (TH2L (CDR U) A1 A2 C1 C2))
((EQ (CAR U) (QUOTE OR)) (AND (TH1L (CADR U) A1 A2 C1 C2)
(TH1L (CADDR U) A1 A2 C1 C2) ))
((EQ (CAR U) (QUOTE IMPLIES)) (AND (TH1L (CADDR U) A1 A2 C1
C2) (TH1R (CADR U) A1 A2 C1 C2) ))
((EQ (CAR U) (QUOTE EQUIV)) (AND (TH2L (CDR U) A1 A2 C1 C2)
(TH2R (CDR U) A1 A2 C1 C2) ))
(T (ERROR (LIST (QUOTE THL) U A1 A2 C1 C2)))
)))

(THR (LAMBDA (U A1 A2 C1 C2) (COND
((EQ (CAR U) (QUOTE NOT)) (TH1L (CADR U) A1 A2 C1 C2))
((EQ (CAR U) (QUOTE AND)) (AND (TH1R (CADR U) A1 A2 C1 C2)
(TH1R (CADDR U) A1 A2 C1 C2) ))
((EQ (CAR U) (QUOTE OR)) (TH2R (CDR U) A1 A2 C1 C2))
A1 A2 C1 C2))
A1 A2 C1 C2) (TH11 (CADDR U) (CADR U) A1 A2 C1 C2) ))
(T (ERROR (LIST (QUOTE THR) U A1 A2 C1 C2)))
)))

(TH1L (LAMBDA (V A1 A2 C1 C2) (COND
((ATOM V) (OR (MEMBER V C1)
(TH (CONS V A1) A2 C1 C2) ))
(T (OR (MEMBER V C2) (TH A1 (CONS V A2) C1 C2) ))
)))

(TH1R (LAMBDA (V A1 A2 C1 C2) (COND
((ATOM V) (OR (MEMBER V A1)
(TH A1 A2 (CONS V C1) C2) ))
(T (OR (MEMBER V A2) (TH A1 A2 C1 (CONS V C2))))
)))

(TH2L (LAMBDA (V A1 A2 C1 C2) (COND
((ATOM (CAR V)) (OR (MEMBER (CAR V) C1)
(TH1L (CADR V) (CONS (CAR V) A1) A2 C1 C2)))
(T (OR (MEMBER (CAR V) C2) (TH1L (CADR V) A1 (CONS (CAR V)
A2) C1 C2)))
)))

(TH2R (LAMBDA (V A1 A2 C1 C2) (COND
((ATOM (CAR V)) (OR (MEMBER (CAR V) A1)
(TH1R (CADR V) A1 A2 (CONS (CAR V) C1) C2)))
(T (OR (MEMBER (CAR V) A2) (TH1R (CADR V) A1 A2 C1
(CONS (CAR V) C2))))
)))

(TH11 (LAMBDA (VI V2 A1 A2 C1 C2) (COND
((ATOM VI) (OR (MEMBER VI C1) (TH1R V2 (CONS VI A1) A2 C1
C2)))
(T (OR (MEMBER VI C2) (TH1R V2 A1 (CONS VI A2) C1 C2)))
)))
))

TRACE ((THEOREM TH1 TH2 TH THL THR TH1L TH1R TH2L TH2R TH11))

THEOREM
((ARROW (P) ((OR P Q))))

UNTRACE ((THEOREM TH1 TH2 THR THL TH1L TH1R TH2L TH2R TH11))

THEOREM
((ARROW ((OR A (NOT B))) ((IMPLIES (AND P Q) (EQUIV P Q))) ))

STOP)))    )))     )))     )))
FIN     END OF LISP RUN        M948-1207 LEVIN
------------------------------------------------------------------------

WANG ALGORITHM FOR THE PROPOSITIONAL CALCULUS

NIL
WARNING: DEFUN/DEFMACRO: redefining TH; it was traced!
NIL
;; Tracing function THEOREM.
;; Tracing function TH1.
;; Tracing function TH2.
;; Tracing function TH.
;; Tracing function THL.
;; Tracing function THR.
;; Tracing function TH1L.
;; Tracing function TH1R.
;; Tracing function TH2L.
;; Tracing function TH2R.
;; Tracing function TH11.
(THEOREM TH1 TH2 TH THL THR TH1L TH1R TH2L TH2R TH11)
1. Trace: (THEOREM '(ARROW (P) ((OR P Q))))
2. Trace: (TH1 'NIL 'NIL '(P) '((OR P Q)))
3. Trace: (TH1 '(P) 'NIL 'NIL '((OR P Q)))
4. Trace: (TH2 '(P) 'NIL 'NIL 'NIL '((OR P Q)))
5. Trace: (TH2 '(P) 'NIL 'NIL '((OR P Q)) 'NIL)
6. Trace: (TH '(P) 'NIL 'NIL '((OR P Q)))
7. Trace: (THR '(OR P Q) '(P) 'NIL 'NIL 'NIL)
8. Trace: (TH2R '(P Q) '(P) 'NIL 'NIL 'NIL)
8. Trace: TH2R ==> (P)
7. Trace: THR ==> (P)
6. Trace: TH ==> (P)
5. Trace: TH2 ==> (P)
4. Trace: TH2 ==> (P)
3. Trace: TH1 ==> (P)
2. Trace: TH1 ==> (P)
1. Trace: THEOREM ==> (P)
(P)
(THEOREM TH1 TH2 THR THL TH1L TH1R TH2L TH2R TH11)
1. Trace: (TH 'NIL '((OR A (NOT B))) 'NIL '((IMPLIES (AND P Q) (EQUIV P Q))))
2. Trace: (TH '(A) 'NIL 'NIL '((IMPLIES (AND P Q) (EQUIV P Q))))
3. Trace: (TH '(A) '((AND P Q)) 'NIL '((EQUIV P Q)))
4. Trace: (TH '(Q P A) 'NIL 'NIL '((EQUIV P Q)))
4. Trace: TH ==> (P A)
3. Trace: TH ==> (P A)
2. Trace: TH ==> (P A)
2. Trace: (TH 'NIL '((NOT B)) 'NIL '((IMPLIES (AND P Q) (EQUIV P Q))))
3. Trace: (TH 'NIL 'NIL '(B) '((IMPLIES (AND P Q) (EQUIV P Q))))
4. Trace: (TH 'NIL '((AND P Q)) '(B) '((EQUIV P Q)))
5. Trace: (TH '(Q P) 'NIL '(B) '((EQUIV P Q)))
5. Trace: TH ==> (P)
4. Trace: TH ==> (P)
3. Trace: TH ==> (P)
2. Trace: TH ==> (P)
1. Trace: TH ==> (P)
(P)
T
[61]>
</pre>

<p>Note, the output obviously differ in the form, but the semantics
are the same, notably the result of the theorem function calls is
"true" both in 2014 Common Lisp and in 1966 LISP 1.5. </p>

<ul>
<li><a href="wang-cl.lisp">wang-cl.lisp</a>
<li><a href="wang.job">wang.job</a>
</ul>

</div>```
ViewGit