; In my last post, McCarthy-60 Lisp in Newlisp
; (1) McCarthy-60 Lisp, the version from his "Recursive functions..."
; paper was defined in Newlisp. "Defined" because Newlisp is
; Lisp, so McCarthy-60 Lisp functions (and special operators)
; can be "just defined" as Newlisp functions and special
; operator. Such a Newlisp + defined function behaves like
; original McCarthy's Lisp. I guess that it could be done
; even more easily in Lisp dialects more similar to McCarthy
; 60 Lisp, for example, Picolisp or Scheme.
; (2) The legendary McCarthy's function EVAL was defined. Some
; care was required, because the function as defined in McCarthy's
; article, but also in other contemporary manuals and memos
; had errors. Paul Graham's paper "The Roots of Lisp" can be
; recommended.
; In this post another instance of McCarthy-60 Lisp running on top
; of that is implemented.
; For clarity, different keywords will be used in each "instance"
; of Lisp. For example, if we write:
;
; (lambda(xx)(cons xx (cons xx (quote ()))))
;
; in Newlisp, then
;
; (LAMBDA(XX)(CONS XX (CONS XX (QUOTE ()))))
;
; will be used in McCarthy-60 Lisp defined in Newlisp, and also
;
; (LAMBDA.1(XX)(CONS.1 XX (CONS.1 XX (QUOTE.1 ()))))
;
; in McCarthy-60 Lisp interpreted in previous Lisp. And also
;
; (LAMBDA.2(XX)(CONS.2 XX (CONS.2 XX (QUOTE.2 ()))))
;
; in McCarthy-60 Lisp interpreted in previous Lisp, described in
; this post.
;
;
;
; --------------
;
;
; McCarthy-60 EVAL has two arguments:
;
; (EVAL <e> <a>)
;
; where <e> is expression that is evaluated, and <a> is association
; list that contains values of the functions and variables used in
; <e>. For example, <a> might look like:
;
; ((X 37)(f (LAMBDA.1(x)(CONS.1 x (QUOTE.1 NIL)))))
;
; if X or f occurs in <e>, the respective values will be used.
; McCarthy-60 EVAL is not very efficient, but is conceptually
; simple.
;
; Such definition of EVAL allows definition of whole interpreters
; as association list, and that's what is described in this post:
; interpreter of McCarthy-60 Lisp, in the form of association
; list that can be supplied to - McCarthy-60 Lisp.
;
; This is how this interpreter looks like:
(setf McCarthy-60-interpreter
'(QUOTE
(
;-------------------------
(EVAL.1 (LABEL.1 EVAL.1
(LAMBDA.1 (e a)
(COND.1
((ATOM.1 e) (ASSOC.1 e a))
;-------------------------
((ATOM.1 (CAR.1 e))
(COND.1
((EQ.1 (CAR.1 e) (QUOTE.1 QUOTE.2))
(CAR.1 (CDR.1 e)))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 ATOM.2))
(ATOM.1 (EVAL.1 (CAR.1 (CDR.1 e))
a)))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 EQ.2))
(EQ.1 (EVAL.1 (CAR.1 (CDR.1 e))
a)
(EVAL.1 (CAR.1 (CDR.1 (CDR.1 e)))
a)))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 COND.2))
(EVCON.1 (CDR.1 e) a))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 AND.2))
(EVAL.1 (CONS.1 (QUOTE.1 COND.2)
(CONS.1 (CDR.1 e)
(QUOTE.1 (((QUOTE.2 T)
(QUOTE.2 F))))))
a))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 CAR.2))
(CAR.1 (EVAL.1 (CAR.1 (CDR.1 e)) a)))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 CDR.2))
(CDR.1 (EVAL.1 (CAR.1 (CDR.1 e)) a)))
;-------------------------
((EQ.1 (CAR.1 e) (QUOTE.1 CONS.2))
(CONS.1 (EVAL.1 (CAR.1 (CDR.1 e))
a)
(EVAL.1 (CAR.1 (CDR.1 (CDR.1 e)))
a)))
;-------------------------
((QUOTE.1 T) (EVAL.1 (CONS.1 (ASSOC.1 (CAR.1 e)
a)
(CDR.1 e))
a))))
;-------------------------
((EQ.1 (CAR.1 (CAR.1 e)) (QUOTE.1 LABEL.2))
(EVAL.1 (CONS.1 (CAR.1 (CDR.1 (CDR.1 (CAR.1 e))))
(CDR.1 e))
(CONS.1 (LIST.1 (CAR.1 (CDR.1 (CAR.1 e)))
(CAR.1 e))
a)))
;-------------------------
((EQ.1 (CAR.1 (CAR.1 e)) (QUOTE.1 LAMBDA.2))
(EVAL.1 (CAR.1 (CDR.1 (CDR.1 (CAR.1 e))))
(APPEND.1 (PAIR.1 (CAR.1 (CDR.1 (CAR.1 e)))
(EVLIS.1 (CDR.1 e) a))
a)))
))))
;-------------------------
(APPEND.1 (LABEL.1 APPEND.1
(LAMBDA.1(X Y)
(COND.1 ((NULL.1 X) Y)
((QUOTE.1 T)
(CONS.1 (CAR.1 X) (APPEND.1 (CDR.1 X) Y)))))))
;-------------------------
(ASSOC.1 (LABEL.1 ASSOC.1
(LAMBDA.1 (X Y)
(COND.1
((EQ.1 (CAR.1 (CAR.1 Y)) X) (CAR.1 (CDR.1 (CAR.1 Y))))
((QUOTE.1 T) (ASSOC.1 X (CDR.1 Y)))))))
;-------------------------
(PAIR.1 (LABEL.1 PAIR.1
(LAMBDA.1 (X Y)
(COND.1 ((AND.1 (NULL.1 X) (NULL.1 Y)) (QUOTE.1 NIL))
((AND.1 (NOT.1 (ATOM.1 X)) (NOT.1 (ATOM.1 Y)))
(CONS.1 (LIST.1 (CAR.1 X) (CAR.1 Y))
(PAIR.1 (CDR.1 X) (CDR.1 Y))))))))
;-------------------------
(EVLIS.1 (LABEL.1 EVLIS.1
(LAMBDA.1 (m a)
(COND.1 ((NULL.1 m) (QUOTE.1 NIL))
((QUOTE.1 T) (CONS.1 (EVAL.1 (CAR.1 m) a)
(EVLIS.1 (CDR.1 m) a)))))))
;-------------------------
(EVCON.1 (LABEL.1 EVCON.1
(LAMBDA.1 (c a)
(COND.1 ((EVAL.1 (CAR.1 (CAR.1 c)) a)
(EVAL.1 (CAR.1 (CDR.1 (CAR.1 c))) a))
((QUOTE.1 T)
(EVCON.1 (CDR.1 c) a))))))
;-------------------------
(NULL.1 (LAMBDA.1 (X)
(AND.1 (ATOM.1 X) (EQ.1 X (QUOTE.1 NIL)))))
;-------------------------
(NOT.1 (LAMBDA.1 (X)
(COND.1 (X (QUOTE.1 F))
((QUOTE.1 T)(QUOTE.1 T)))))
;-------------------------
(LIST.1 (LAMBDA.1 (X Y) (CONS.1 X (CONS.1 Y (QUOTE.1 NIL)))))
)
)
)
; Is there any difference between EVAL.1 and EVAL defined in
; last post? Yes, EVAL used "building blocks" like operators AND
; or LIST. These can be easily defined in Newlisp, but require
; different approach in McCarthy-60 Lisp, where one cannot use
; variable number of arguments or define special operators.
; How code that could be evaluated by EVAL.1 look like? Well, it
; uses keywords like QUOTE.2, ATOM.2, CONS.2. And how it is called?
; Here is an example:
;
;
; (eval (expand '(EVAL (QUOTE (EVAL.1 (QUOTE.1
; ((LAMBDA.2 (XX)
; (CONS.2 XX
; (CONS.2 XX
; (QUOTE.2 ()))))
; (QUOTE.2 somedata)))
; (QUOTE.1 ())
; )
; )
; McCarthy-60-interpreter
; )
; 'McCarthy-60-interpreter
; )
; )
;
; The result should be (somedata somedata).
;
; In the rest of this post, McCarthy-60 Lisp is defined in Newlisp,
; more-less, like it was done in previous post, and then the code
; above (using somedata) will be evaluated, so those who are
; interested can, as usually, cut and paste whole post in their
; editor and evaluate in Newlisp. The result of the evaluation
; of the code above (with debug-wrap feature from my library) is
; correct; this is how part of the output on screen can look like.
(load "http://www.instprog.com/Instprog.default-library.lsp")
;---------------------------------------------------------------
; Newlisp has not dotted pairs, so they are emulated here.
;---------------------------------------------------------------
(define (dotform-atom? L)
(atom? L))
(define (dotform-base? L)
(and (list? L)
(= (length L) 3)
(= (nth 1 L) '.)))
(define (dotform-recursive? L)
(or (dotform-atom? L)
(and (dotform-base? L)
(dotform-recursive? (first L))
(dotform-recursive? (last L)))))
(define (listform-atom?)
(and (atom? L)
(not (= L 'NIL))))
(define (listform-base? L)
(and (list? L)
(not (dotform-base? L))))
(define (listform-recursive? L)
(or (listorm-atom? L)
(and (listform-base? L)
(for-all? listform-recursive? L))))
(define (dotform L)
(cond ((dotform-atom? L) L)
((dotform-base? L) (list (dotform (first L))
'.
(dotform (last L))))
((= (length L) 0) 'NIL)
((> (length L) 0) (list (dotform (first L))
'.
(dotform (rest L))))))
(define (listform L)
(cond ((listform-atom? L) L)
((= L '()) L)
((listform-base? L) (cons (listform (first L))
(listform (rest L))))
((= L 'NIL) '())
((dotform-base? L) (let((L1 (listform (first L)))
(L2 (listform (last L))))
(if (listform-base? L2)
(cons L1 L2)
(list L1 '. L2))))))
(define (listform-args L)
(cond ((empty? L) L)
((= (first L) (quote .))(listform (rest L)))
(true (listform L))))
;===============================================================
; DEFINITION OF FEW BASIC OPERATORS.
; THESE OPERATORS ARE ELEMENTS OF META-LANGUAGE, DEFINED IN
; META-META-LANGUAGE (Newlisp)
;---------------------------------------------------------------
(define-macro (COND)
(letn((done nil)
(result nil)
(arglist (args))
(largs (listform-args (args))))
(dolist(clause largs done ind)
(setf ind (eval (symbol-from-sexpr '(debug-wrap indent))))
;'(println (dup " " ind) "????? COND clause: " (nth 0 clause))
(let ((l (eval (nth 0 clause))))
(if (= l 'T)
(begin '(println (dup " " ind) "+++++ COND clause "
(nth 0 clause) " evaluates to: " (listform l))
(setf result (listform (eval (nth 1 clause))))
(setf done true))
'(println (dup " " ind) "----- COND clause evaluates to: "
(listform l))
)))
(if (not done)
(throw-error (append (dup " " ind)
"!!!!! COND without any alternative satisfied."))
(begin '(println (dup " " ind) "!!!!! COND expr evaluates to "
(listform result))
result))))
(define-macro (AND)
(letn((arglist (args))
(largs (listform arglist)))
(if (eval (cons 'and (map (lambda(X)(expand '(= X (quote T))
'X))
largs)))
(quote T)
(quote F))))
(define-macro (OR)
(letn((arglist (args))
(largs (listform arglist)))
(if (eval (cons 'or (map (lambda(X)(expand '(= X (quote T))
'X))
largs)))
(quote T)
(quote F))))
(define-macro (NOT X)
(let ((lx (listform X)))
(if (= (eval lx) (quote T))
(quote F)
(if (= (eval lx) (quote F))
(quote T)
(throw-error
" NOT called with argument evaluating to T OR F.")))))
;---------------------------------------------------------------
(define (LIST)
(listform (let((a (args)))
(cond ((empty? a) (quote NIL))
((quote T) (list (dotform (first a))
'. (dotform (rest a))))))))
;---------------------------------------------------------
(define-macro (QUOTE X) (listform X))
;---------------------------------------------------------
(define-macro (LAMBDA)
(append (lambda) (args)))
;---------------------------------------------------------
(define-macro (LABEL)
(let((l1 (first (args)))
(l2 (last (args))))
;(println l1 l2)
(set l1 (eval l2))))
;===============================================================
; FIVE ELEMENTARY S-FUNCTIONS.
;---------------------------------------------------------------
; 1. ATOM
;---------------------------------------------------------------
(define (ATOM X)
(if (atom? (dotform X)) (quote T) (quote F)))
;---------------------------------------------------------------
; 2. EQ
;---------------------------------------------------------------
(define (EQ X Y)
(let((X (dotform X))
(Y (dotform Y)))
(if (and (atom? (dotform X)) (atom? (dotform Y)))
(if (= X Y) (quote T) (quote F))
(throw-error (string "** EQ undefined for " X " AND " Y "**")))))
;---------------------------------------------------------------
; 3. CAR
;---------------------------------------------------------------
(define (CAR X)
(listform
(let ((X (dotform X)))
(cond ((= X 'NIL) (throw-error "CAR undefined for NIL."))
((atom? X)
(throw-error (string "CAR undefined for atomic symbol " X)))
(true (first X))))))
;---------------------------------------------------------------
; 4. CDR
;---------------------------------------------------------------
(define (CDR X)
(listform
(let ((X (dotform X)))
(cond ((= X 'NIL) (throw-error "CAR undefined for NIL."))
((atom? X) (throw-error
(string "CDR undefined for atomic symbol " X)))
(true (last X))))))
;---------------------------------------------------------------
; 5. CONS
;---------------------------------------------------------------
(define (CONS X Y)
(listform (let ((X (dotform X))
(Y (dotform Y)))
(list X '. Y))))
;---------------------------------------------------------------
; DEFINITION OF IMPORTANT S-FUNCTIONS IN META-LANGUAGE
; STRICTLY FOLLOWED MCCARTHY'S ARTICLE. LOOK EXAMPLES AS BEST
; EXPLANATION
;---------------------------------------------------------------
; NULL
;---------------------------------------------------------------
(define (NULL X)
(listform (AND (ATOM X) (EQ X (QUOTE NIL)))))
;---------------------------------------------------------------
; S-FUNCTIONS USEFUL WHEN S-EXPRESSIONS ARE REGARDED AS LISTS
; DEFINED IN META-LANGUAGE IN MCCARTHY'S PAPER
;---------------------------------------------------------------
;---------------------------------------------------------------
; 1. APPEND
;---------------------------------------------------------------
(define (APPEND X Y)
(listform (COND ((NULL X) Y)
((QUOTE T) (CONS (CAR X) (APPEND (CDR X) Y))))))
;---------------------------------------------------------------
; PAIR
;
; (PAIR (QUOTE (<s1> ... <sn>)) (QUOTE (<t1> ... <tn>))) =>
; ((<s1> <t1>) ... (<sn> <tn>))
;
;---------------------------------------------------------------
(define (PAIR X Y)
(listform
(COND ((AND (NULL X) (NULL Y)) (QUOTE NIL))
((AND (NOT (ATOM X)) (NOT (ATOM Y)))
(CONS (LIST (CAR X) (CAR Y))
(PAIR (CDR X) (CDR Y)))))))
;---------------------------------------------------------------
; ASSOC
;
; ASSOC returns the "value" of variable X in "association LIST" y.
; for example,
;
; (ASSOC (QUOTE (X)) (QUOTE ((W (A B)) (X (C D)) (Y (E F)))))
;
; returns (C D).
;
; If variable is NOT "stored" in association LIST, then there
; will be error in attempt to find CAAR of empty list.
(define (ASSOC X Y)
(let((X (dotform X))
(Y (listform Y)))
(when (or (= X 'F) (= X 'T))
(throw-error "ASSOC CALLED WITH WRONG ARGUMENT."))
(listform (COND ((AND (ATOM Y)
(EQ Y (QUOTE NIL)))
(throw-error (string "ASSOC " X " in "
Y " is impossible.")))
((EQ (CAR (CAR Y)) X) (CAR (CDR (CAR Y))))
((QUOTE T) (ASSOC X (CDR Y)))))))
;---------------------------------------------------------------
; APPQ
;
; (APPQ (QUOTE (<expr1> ... <exprn>)))
;
; ===> ((QUOTE <expr1>)...(QUOTE <exprn>))
;---------------------------------------------------------------
(define (APPQ m)
(listform (COND ((NULL m) (QUOTE NIL))
((QUOTE T) (CONS (LIST (QUOTE QUOTE) (CAR m))
(APPQ (CDR m)))))))
;---------------------------------------------------------------
; EVAL, EVCON, EVLIS
;---------------------------------------------------------------
(define (EVLIS m a)
(listform (COND ((NULL m) (QUOTE NIL))
((QUOTE T) (CONS (EVAL (CAR m) a)
(EVLIS (CDR m) a))))))
(define (EVCON c a)
(COND ((EVAL (CAR (CAR c)) a) (EVAL (CAR (CDR (CAR c)))
a))
((QUOTE T) (EVCON (CDR c) a))))
(define (EVAL e a)
(listform
(COND ((ATOM e) (listform (ASSOC e a)))
;----------------------------
((ATOM (CAR e))
;----------------------------
(COND ((EQ (CAR e) (QUOTE QUOTE.1))
(CAR (CDR e)))
;----------------------------
((EQ (CAR e) (QUOTE ATOM.1))
(ATOM (EVAL (CAR (CDR e)) a)))
;----------------------------
((EQ (CAR e) (QUOTE EQ.1))
(EQ (EVAL (CAR (CDR e)) a)
(EVAL (CAR (CDR (CDR e))) a)))
;----------------------------
((EQ (CAR e) (QUOTE COND.1)) (EVCON (CDR e) a))
;----------------------------
((EQ (CAR e) (QUOTE AND.1))
(EVAL (CONS (QUOTE COND.1)
(CONS (CDR e)
(QUOTE (((QUOTE.1 T)
(QUOTE.1 F))))))
a))
;----------------------------
((EQ (CAR e) (QUOTE CAR.1))
(CAR (EVAL (CAR (CDR e)) a)))
;----------------------------
((EQ (CAR e) (QUOTE CDR.1))
(CDR (EVAL (CAR (CDR e)) a)))
;----------------------------
((EQ (CAR e) (QUOTE CONS.1))
(CONS (EVAL (CAR (CDR e)) a)
(EVAL (CAR (CDR (CDR e))) a)))
;----------------------------
((QUOTE T) (EVAL (listform (CONS (ASSOC (CAR e) a)
(CDR e)))
a))))
;----------------------------
((EQ (CAR (CAR e)) (QUOTE LABEL.1))
(EVAL (listform (CONS (CAR (CDR (CDR (CAR e))))
(CDR e)))
(listform (CONS (LIST (CAR (CDR (CAR e)))
(CAR e))
a))))
;----------------------------
((EQ (CAR (CAR e)) (QUOTE LAMBDA.1))
(EVAL (listform (CAR (CDR (CDR (CAR e)))))
(listform (APPEND (PAIR (CAR (CDR (CAR e)))
(EVLIS (CDR e) a)) a)))))))
(debug-wrap EVAL)
(eval (expand '(EVAL (QUOTE (EVAL.1 (QUOTE.1 ((LAMBDA.2 (XX)
(CONS.2 XX (CONS.2 XX (QUOTE.2 ()))))
(QUOTE.2 somedata)))
(QUOTE.1 ())
)
)
McCarthy-60-interpreter
)
'McCarthy-60-interpreter
)
)
(exit)
|
