McCarthy's 1960 "Recursive Functions ..." Lisp in Newlisp.





;===============================================================
;
; McCarthy's Lisp, as described in  "Recursive functions", 1960,
; (40+ functions and operators)  is implemented in Newlisp. I'll
; use the term "McCarthy60 Lisp" for that dialect.
;
;     http://www-formal.stanford.edu/jmc/recursive.html
;  
; As  syntax  of  Newlisp  and  McCarthy60  Lisp  are  the same,
; implementation  is  very  simple:  it  is   enough  to  define
; McCarthy60  Lisp functions  and operators as Newlisp functions  
; or eventually, fexprs. It is convenient that Newlisp functions
; use lower case letters, while McCarthy60 Lisp uses upper case.
;  
; There  are  some  important  differences  between  Newlisp and
; McCarthy60  Lisp.  Newlisp  doesn't  have  dottedpairs, it has
; lists only.  McCarthy60 Lisp uses T for 'true' and F (not NIL)  
; for 'false'.  Newlisp uses true and nil.  In some Lisp dialect
; without   these   two   differences,   for   example,  Scheme,
; implementation could be even simpler. However, taking this into
; consideration, Newlisp and McCarthy60 Lisp can be mixed freely.
;
; The implementation could be of  interest for those who want to
; understand  and  who  are  not   sure   about   some  details,
; particularly because there are few errors in original article,
; as recently discussed in this blog.
;
; There  are lot of  comments and  examples "apostrophed out" in
; code.
;
; If you have some comment, or you think something could be done
; better, I'd like to hear it.
;
; Inspired by MARK STOCK'S recent project
;  
;      http://hoop-la.ca/apple2/2010/retrochallenge.html
;
; Much more geeky than this one.
;
; Another very  useful discussion is Paul Graham's "The Roots of
; Lisp."
;
;         http://www.paulgraham.com/rootsoflisp.html
;
;---------------------------------------------------------------

   (set '[println.supressed] true)
   (load "http://www.instprog.com/Instprog.default-library.lsp")
   (set '[println.supressed] nil)

;---------------------------------------------------------------
; 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))))

  '(println= (listform-args '()))
  '(println= (listform-args '(. OOOPS)))
  '(println= (listform-args '(a b c d)))
 

(dolist (X '(NIL                    ()                       (())
            (NIL)                   ((NIL))                  (NIL . (NIL . NIL))
            ((NIL . NIL) . NIL)     ((A . NIL) . (B . NIL))  (A)                    
            (A . B)                 (() . ())                (B . (C))
            (A B C)))
        '(println= X (dotform X) (listform X)))

;===============================================================
; 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)
                 (when (= (eval (nth 0 clause)) 'T)
                       (setf result (eval (nth 1 clause)))
                       (setf done true)))
             (if (not done)
                 (throw-error "COND without any alternative satisfied.")
                 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))))
              
          '(println= (AND 1 2) "should be 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.")))))
          
         '(println= (NOT (quote T)) (NOT (quote F))
                    "should be F AND T respectively.")

      ;---------------------------------------------------------------
      ; ABBREVIATION LIST
      ;
      ; STATUS OF THE ABBREVIATION LIST IS NOT CLEAR, i.e. IS IT DEFINED USING
      ; BOTH META-LANGUAGE OR IN META-META-LANGUAGE.
      ;
      ; AS IT CANNOT BE S-FUNCTION I THINK IT iS BEST TO CONSIDER IT AS
      ; ANOTHER SPECIAL OPERATOR OF META-LANGUAGE DEFINED IN META-META-LANGUAGE,
      ; SIMILAR TO COND.
      ;
      ; (LIST (quote e1) ... (quote en)) => (e1 . (... . (en . NIL)))
      ;---------------------------------------------------------------

      (define (LIST)
        (let((a (args)))
            (cond ((empty? a) (quote NIL))
                  ((quote T) (list (dotform (first a))
                                   '. (dotform (rest a)))))))

          '(println= (listform (LIST (quote e1) (quote e2)
                                     (quote ...) (quote en)))
                     "should be (e1 e2 ... en).")
                 
      ;---------------------------------------------------------
              
      (define-macro (QUOTE x) x)
          '(println= (QUOTE (X X)) "should be (X X).")
          
      ;---------------------------------------------------------
      
      (define-macro (LAMBDA)
           (append (lambda) (args)))
           
        '(println ((LAMBDA(x)x) (QUOTE A)))
     
      ;---------------------------------------------------------
      
      (define-macro (LABEL)
        (let((l1 (first (args)))
             (l2 (last (args))))
            ;(println l1 l2)
            (set l1 (eval l2))))

;===============================================================
; FIVE ELEMENTARY S-FUNCTIONS.
;
; THESE S-FUNCTIONS ARE ELEMENTS OF THE META LANGUAGE, AND THEY ARE
; DEFINED IN META-META-LANGUAGE (NEWLISP).
;
; ALL S-FUNCTIONS ACCEPT ARGUMENTS IN FORM (A . B) AND (A B).

;---------------------------------------------------------------
; 1. ATOM
;---------------------------------------------------------------

(define (ATOM x)
        (if (atom? (dotform x)) (quote T) (quote F)))
        
'(println= (ATOM 'X) "should be T.")
'(println= (ATOM '(X . A)) "should be 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 "**")))))
            
'(println= (EQ 'X 'X) "should be T.")
'(println= (EQ 'X 'A) "should be F.")
'(println= (EQ 'X '(X . A)) "should be undefined.")

;---------------------------------------------------------------
; 3. CAR
;---------------------------------------------------------------

(define (CAR x)
  (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)))))
              
'(println= (CAR '(X . A)) "should be X.")
'(println= (CAR '((X . A) . Y)) "should be (X . A).")

;---------------------------------------------------------------
; 4. CDR
;---------------------------------------------------------------

(define (CDR x)
  (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)))))
              
'(println= (CDR '(X . A)) "should be A.")
'(println= (CDR '((X . A) . Y)) "should be Y.")
              
;---------------------------------------------------------------
; 5. CONS
;---------------------------------------------------------------              

(define (CONS x y)
     (let ((x (dotform x))
           (y (dotform y)))
           (list x '. y)))

'(println= (CONS 'X 'A) "should be (X . A).")
'(println= (CONS '(X . A) 'Y) "should be ((X . A). Y).")

;---------------------------------------------------------------
; DEFINITION OF IMPORTANT S-FUNCTIONS IN META-LANGUAGE
; STRICTLY FOLLOWED MCCARTHY'S ARTICLE. LOOK EXAMPLES AS BEST
; EXPLANATION

;---------------------------------------------------------------
; FF
;
; Returns first element of the LIST recursively
;---------------------------------------------------------------

(define (FF x)
        (COND ((ATOM x) x)
              ((QUOTE T) (FF (CAR x)))))
             
'(println= (FF (QUOTE A)) "should be A.")
'(println= (FF (QUOTE ((A . B) . C))) "should be A.")
'(println= (FF (QUOTE (((D) . B) . C))) "should be D.")

;---------------------------------------------------------------
; SUBST
;
; (SUBST x y z) returns result of substitution of x for y in z
;---------------------------------------------------------------

(define (SUBST x y z)
        (COND ((ATOM z) (COND ((EQ z y) x)
                              ((QUOTE T) z)))
              ((QUOTE T) (CONS (SUBST x y (CAR z))
                               (SUBST x y (CDR z))))))

'(println= (SUBST (QUOTE (X . A)) (QUOTE B) (QUOTE ((A . B) . C)))
          "should be ((A . (X . A)) . C)")

;---------------------------------------------------------------
; EQUAL
;
; Generalization of S-function EQ for all s-expressions.
;---------------------------------------------------------------

(define (EQUAL x y)
        (OR (AND (ATOM x) (ATOM y) (EQ x y))
            (AND (NOT (ATOM x))
                 (NOT (ATOM y))
                 (EQUAL (CAR x) (CAR y))
                 (EQUAL (CDR x) (CDR y)))))
                 
'(println= (EQUAL (QUOTE (A . B)) (QUOTE (A . B))) "should be T")

;---------------------------------------------------------------
; NULL
;---------------------------------------------------------------

(define (NULL x)
        (AND (ATOM x) (EQ x (QUOTE NIL))))
 
'(println= (NULL (QUOTE NIL)) "should be T")

;---------------------------------------------------------------
; S-functions CAAR, CADR etc
;
; (CADDAR x) = (CAR (CDR (CDR (CAR x))))
;---------------------------------------------------------------

(define (CAAR   x)(CAR (CAR   x)))
(define (CADR   x)(CAR (CDR   x)))
(define (CDAR   x)(CDR (CAR   x)))
(define (CDDR   x)(CDR (CDR   x)))
(define (CAAAR  x)(CAR (CAAR  x)))
(define (CAADR  x)(CAR (CADR  x)))
(define (CADAR  x)(CAR (CDAR  x)))
(define (CADDR  x)(CAR (CDDR  x)))
(define (CDAAR  x)(CDR (CAAR  x)))
(define (CDADR  x)(CDR (CADR  x)))
(define (CDDAR  x)(CDR (CDAR  x)))
(define (CDDDR  x)(CDR (CDDR  x)))
(define (CADDAR x)(CAR (CDDAR x)))

            ;-------------------------------------------------
            ; THIS IS HOW IT CAN BE DONE IN META-META-LANGUAGE

            ; (let((L '(CAR CDR))
            ;      (n 10000))
            ;    (dotimes(i (/ n 2))
            ;      (let ((s (pop L)))
            ;        (dolist(j '(CAR CDR))
            ;          (set 's0 (sym (APPEND (chop (string j)) (rest (string s)))))
            ;          (set s0 (expand (lambda(x)(j (s x))) 's 'j))
            ;          (push s0 L -1)))))
            ;

'(dolist (i '(CAR CDR
             CAAR  CADR  CDAR  CDDR
             CAAAR CAADR CADAR CADDR
             CDAAR CDADR CDDAR CDDDR))
    (eval (expand '(println= (i (QUOTE (((1 . 2).(3 . 4)).((5 . 6).(7 . 8))))))
                  'i)))

;---------------------------------------------------------------
; S-FUNCTIONS USEFUL WHEN S-EXPRESSIONS ARE REGARDED AS LISTS
; DEFINED IN META-LANGUAGE IN MCCARTHY'S PAPER
;---------------------------------------------------------------

;---------------------------------------------------------------
; 1. APPEND
;---------------------------------------------------------------

(define (APPEND x y)
    (COND ((NULL x) y)
          ((QUOTE T) (CONS (CAR x) (APPEND (CDR x) y)))))

'(println= (listform (APPEND (QUOTE (A B)) (QUOTE (C D E))))
          "should be (A B C D E).")

;---------------------------------------------------------------
; 2. AMONG
;
; (AMONG (QUOTE <s>) (QUOTE <l>))
;
; returns T if <s> is element of the LIST <l>
;         F otherwise
;
;---------------------------------------------------------------
              
(define (AMONG x y)
        (AND (NOT (NULL y))
             (OR (EQUAL x (CAR y))
                 (AMONG x (CDR y)))))
                 
'(println= (AMONG (QUOTE X) (QUOTE (A B X C))) "should be T.")
'(println= (AMONG (QUOTE X) (QUOTE (A B D C))) "should be F.")


;---------------------------------------------------------------
; PAIR
;
; (PAIR (QUOTE (<s1> ... <sn>)) (QUOTE (<t1> ... <tn>))) =>
;       ((<s1> <t1>) ... (<sn> <tn>))
;---------------------------------------------------------------

(define (PAIR x y)
        (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))))))
              
'(println= (listform (PAIR (QUOTE (A B C)) (QUOTE (X (Y Z) U))))
          "should be ((A X)(B (Y Z)) (C U))")
          
;---------------------------------------------------------------
; 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)
  (COND ;((AND (ATOM y)
        ;  (EQ y (QUOTE NIL))) (throw-error "ASSOC " x " in " y " is impossible."))
        ((EQ (CAAR y) x) (CADAR y))
        ((QUOTE T) (ASSOC x (CDR y)))))

'(println= (listform (ASSOC (QUOTE X) (QUOTE ((W (A B)) (X (C D)) (Y (E F))))))
          "should be (C D).")
          
;---------------------------------------------------------------
; SUBLIS (substitution defined by LIST).
;---------------------------------------------------------------
   
(define (SUB2 x z)
        (COND ((NULL x) z)
              ((EQ (CAAR x) z) (CADAR x))
              ((QUOTE T) (SUB2 (CDR x) z))))
              
(define (SUBLIS x y)
        (COND ((ATOM y) (SUB2 x y))
              ((QUOTE T) (CONS (SUBLIS x (CAR y))
                               (SUBLIS x (CDR y))))))

'(println= (listform (SUBLIS (QUOTE ((X (A B)) (Y (B C))))
                            (QUOTE (A . (X . Y)))))
          "should be (A (A B) B C).")

;---------------------------------------------------------------
; APPQ
;
; (APPQ (QUOTE (<expr1> ... <exprn>)))
;
;                        ===> ((QUOTE <expr1>)...(QUOTE <exprn>))
;---------------------------------------------------------------
 
(define (APPQ m)
        (COND ((NULL m) (QUOTE NIL))
              ((QUOTE T) (CONS (LIST (QUOTE QUOTE) (CAR m))
                               (APPQ (CDR m))))))

'(println= (listform (APPQ (QUOTE ((+ 1 1) 2 3))))
         "should be ((QUOTE (+ 1 1)) (QUOTE 2) (QUOTE 3)).")

;---------------------------------------------------------------
; EVAL
;
; in original code there is no branching on EVAL-QUOTE and similar
; functions, but this version is not significantly different, but
; it is much more practical for experiments.
;---------------------------------------------------------------

(define (EVAL e a)
   (COND ((ATOM e) (ASSOC e a))
         ((ATOM (CAR e))

             (COND ((EQ (CAR e) (QUOTE QUOTE)) (EVAL-QUOTE e a))
                   ((EQ (CAR e) (QUOTE ATOM))  (EVAL-ATOM e a))
                   ((EQ (CAR e) (QUOTE EQ))    (EVAL-EQ e a))
                   ((EQ (CAR e) (QUOTE COND))  (EVAL-COND e a))
                   ((EQ (CAR e) (QUOTE CAR))   (EVAL-CAR e a))
                   ((EQ (CAR e) (QUOTE CDR))   (EVAL-CDR e a))
                   ((EQ (CAR e) (QUOTE CONS))  (EVAL-CONS e a))
                   ((QUOTE T)                  (EVAL-REST e a))))

         ((EQ (CAAR e) (QUOTE LABEL))          (EVAL-LABEL e a))
         ((EQ (CAAR e) (QUOTE LAMBDA))         (EVAL-LAMBDA e a))                 
         ((QUOTE T)
             (throw-error
                (string "EVAL unexpected case, e=" e ", a=" a ".")))))
         
    ;-----------------------------------------------------------------+
    ; EVCON:                                                          |
    ;                                                                 |
    ; (EVCON (QUOTE ((<p1> <e1>)..(<pn> <en>))) <a>) =                |
    ;                                                                 |
    ; calculates (EVAL <p1> <a>), (EVAL <p2> <a>),... until it find   |
    ; first (EVAL <pi> <a>) that evaluates to T.                      |
    ;                                                                 |
    ; Then it returns (EVAL <ei> <a>).                                |
    ;-----------------------------------------------------------------+

        (define (EVCON c a)
                (COND ((EVAL (CAAR c) a) (EVAL (CADAR c) a))
                      ((QUOTE T)         (EVCON (CDR c) a))))
                      
    ;---------------------------------------------------------------
    ; EVLIS:
    ;
    ; (EVLIS (QUOTE (<expr1> ... <exprn>)) a)    =>   (<r1> ... <rn>)
    ;
    ; where <ri> = result of the (EVAL (QUOTE <expri> a))
    ;---------------------------------------------------------------

        (define (EVLIS m a)
                (COND ((NULL m)  (QUOTE NIL))
                      ((QUOTE T) (CONS (EVAL (CAR m) a)
                                       (EVLIS (CDR m) a)))))

        ;-------
        ; (EVAL (QUOTE (QUOTE expr1)) a) evaluates to expr1

        (define (EVAL-QUOTE e a)
           (CADR e))  

           '(println= (EVAL (QUOTE (QUOTE A)) (QUOTE ()))
                      "should be A")
           
        ;-------

        (define (EVAL-ATOM e a)
           (ATOM (EVAL (CADR e) a)))

           '(println= (EVAL (QUOTE (ATOM X)) (QUOTE ((X A))))
                      "should be T.")
           '(println= (EVAL (QUOTE (ATOM X)) (QUOTE ((Y OH)(X NIL))))
                      "should be T.")
           '(println= (EVAL (QUOTE (ATOM X)) (QUOTE ((X (A)))))
                      "should be F.")

        ;-------

        (define (EVAL-EQ e a)
           (EQ (EVAL (CADR e) a) (EVAL (CADDR e) a)))
           
           '(println= (EVAL (QUOTE (EQ (QUOTE A) (QUOTE B))) (QUOTE NIL))
                      "should be F.")
           '(println= (EVAL (QUOTE (EQ (QUOTE A) (QUOTE A))) (QUOTE NIL))
                      "should be T.")
           '(println= (EVAL (QUOTE (EQ X (QUOTE A))) (QUOTE ((X A))))
                      "should be T.")

        ;-------

        (define (EVAL-COND e a)
           (EVCON (CDR e) a))
           
           '(println= (EVAL (QUOTE (COND ((ATOM X)(QUOTE FIRST-CHOICE))
                                        ((QUOTE T)(QUOTE SECOND-CHOICE))))
                           (QUOTE ((X Z))))
                     "should be FIRST-CHOICE.")
                 
           '(println= (EVAL (QUOTE (COND ((ATOM X)(QUOTE FIRST-CHOICE))
                                        ((QUOTE T)(QUOTE SECOND-CHOICE))))
                           (QUOTE ((X (EXTRA Z)))))
                     "should be SECOND-CHOICE.")
           
        ;-------

        (define (EVAL-CAR e a)
           (CAR (EVAL (CADR e) a)))
           
           '(println= (EVAL (QUOTE (CAR (QUOTE (X Y))))
                            (QUOTE ((A B))))
                     "should be X.")
           
        ;-------
           
        (define (EVAL-CDR e a)
           (CDR (EVAL (CADR e) a)))
           
             '(println= (listform (EVAL (QUOTE (CDR (QUOTE (X Y))))
                                        (QUOTE ((A B)))))
                     "should be (Y).")

        ;-------

        (define (EVAL-CONS e a)
           (CONS (EVAL (CADR e) a)
                 (EVAL (CADDR e) a)))
                 
                 '(println= (EVAL (QUOTE (CONS (QUOTE X) (QUOTE Y)))
                                  (QUOTE ((X Z))))
                         "should be (X . Y).")
                         
                 '(println= (EVAL (QUOTE (CONS X (QUOTE Y)))
                                  (QUOTE ((X Z))))
                         "should be (Z . Y).")
                         
    ;-------------------------------------------------------
    ; EVAL-REST is the strangest rule for evaluation, from modern point
    ; of view. It is used for evaluation of the lists of the form
    ;
    ;     (FUN <expr1> <expr2> ... <exprn>)
    ;     
    ;
    ; where FUN is some user-defined symbol, so EVAL search its
    ; value in association list a given as argument. EVAL first
    ; calculate the LIST of the evaluated elements
    ;
    ;    (<efun> (EVAL <expr1> a) ... (EVAL <exprn> a))
    ;
    ; and result is then evaluated once again. Some people, for
    ; example, Paul Graham in his paper "Roots of Lisp" suggests
    ; that this is bug, AND I believe he is right. Instead of that,
    ; it will be evaluated as
    ;
    ;    ((ASSOC FUN a) <expr1> ... <exprn>)  
    ;-------------------------------------------------------

        (define (EVAL-REST e a)
           (EVAL (listform (CONS (ASSOC (CAR e) a)
                                 (CDR e))) ; This (CDR e) is used
                                           ; instead of original version
                                           ; (EVLIS (CDR e) a),
                                           ; that is likely bug.
                 a))

                '(println= (EVAL (QUOTE (P (QUOTE (QUOTE A))))
                                (QUOTE ((P ATOM))))
                          "should be F.")

                '(println= (EVAL (QUOTE (P (QUOTE (QUOTE (QUOTE A)))))
                                (QUOTE ((P ATOM))))
                          "should be F.")
                                
                '(println= (EVAL (QUOTE (P (QUOTE A)))
                                (QUOTE ((P R)(R S)(S ATOM))))
                          "should be T.")

                '(println= (listform (EVAL (QUOTE (P (QUOTE (X)) (QUOTE (Y))))
                                          (QUOTE ((P R)(R CONS)))))
                          "should be ((X) Y).")
                
        ;-------------------------------------------------------
        ; LAMBDA-expressions are evaluates by transforming
        ;
        ;  (EVAL (QUOTE ((LAMBDA(p1...pn) expr) expr1 ... exprn))
        ;        (QUOTE ((a1 e1)...(am em))))
        ;
        ; to
        ;
        ;  (EVAL (QUOTE expr)
        ;        (QUOTE ((p1 expr1)...(pn exprn)(a1 e1) ...(an em))))
        ;
        ; and transformed expression is evaluated and result is returned.
        ;-------------------------------------------------------
        
        (define (EVAL-LAMBDA e a)
           (EVAL (CADDAR e)
                 (listform (APPEND (PAIR (CADAR e) (EVLIS (CDR e) a)) a))))

           '(println= (listform (EVAL (QUOTE ((LAMBDA (X)
                                                  (CONS X (QUOTE NIL)))
                                              (QUOTE A)))
                                     (QUOTE (()))))

                     "should be (A).")

           '(println= (listform (EVAL (QUOTE ((LAMBDA (X)(CONS X (QUOTE NIL)))
                                              (CONS G (QUOTE NIL))))
                                      (QUOTE ((G (HOP-CUP-POSKOCIT-CU))))))
                                     
                     "should be (((HOP-CUP-POSKOCIT-CU))).")

        

        ;-------------------------------------------------------
        ; LABEL-expressions are evaluated by transforming
        ;         ;
        ; (EVAL (QUOTE ((LABEL f (LAMBDA...)) expr1 ... exprn))
        ;       (QUOTE ((a1 e1)...(am em))))
        ;
        ; to
        ;
        ; (EVAL (QUOTE ((LAMBDA ...) expr1 ... exprn))
        ;       (QUOTE ((f (LABEL f (LAMBDA...)))(a1 e1)...(am em))))
        ;
        ; and transformed expression is evaluated, and result is returned.
        ;
        ; Locally, it is enough to define label once, it will work:
        ;
        ;  (EVAL(QUOTE ((LABEL f (LAMBDA(X)(CONS X (CONS X (QUOTE NIL)))))
        ;               (f (f (f (f (f (f (f (f (f (QUOTE A))))))))))))
        ;               (QUOTE ()))
        ;-------------------------------------------------------
                 
        (define (EVAL-LABEL e a)
           (EVAL (listform (CONS (CADDAR e) (CDR e)))
                 (listform (CONS (LIST (CADAR e) (CAR e)) a))))
        
           '(println= (EVAL-LABEL (QUOTE ((LABEL f (LAMBDA (X Y)(CONS X Y)))
                                (QUOTE (A))
                                (QUOTE (B))))            
                        (QUOTE ((A1 E1)(A2 E2)))))
                       
           '(println= (EVAL-LABEL
               (QUOTE ((LABEL f (LAMBDA(X)(CONS X (CONS X (QUOTE NIL)))))
                       (f (g (f (g (f (g (f (g (f (QUOTE A))))))))))))
               (QUOTE ((g (LAMBDA(Y)(CONS Y (CONS (QUOTE 1) (QUOTE NIL)))))))))
           
           '(println= (listform
               (EVAL (QUOTE ((LABEL SUBST
                              (LAMBDA (X Y Z)
                                  (COND ((ATOM Z)
                                         (COND ((EQ Y Z) X)
                                               ((QUOTE T) Z)))
                                        ((QUOTE T)
                                             (CONS (SUBST X Y (CAR Z))
                                                   (SUBST X Y (CDR Z)))))))
                             (QUOTE (A)) (QUOTE B) (QUOTE (Z B C))))
                
                    (QUOTE (()))))
                "should be (Z (A) C).")

           '(println= (listform
              (EVAL (QUOTE (SUBST (QUOTE (A)) (QUOTE B) (QUOTE (Z B C))))
                    (QUOTE ((SUBST
                            (LAMBDA (X Y Z)
                                (COND ((ATOM Z)
                                       (COND ((EQ Y Z) X)
                                             ((QUOTE T) Z)))
                                      ((QUOTE T)
                                           (CONS (SUBST X Y (CAR Z))
                                                 (SUBST X Y (CDR Z)))))))))))
               "should be (Z (A) C).")

           '(println= (listform (EVLIS (QUOTE (A . NIL))                   
                                      (QUOTE ((POKOS CAR)(A (X Y))))))
                     "should be ((X Y)).")   

           '(println= (EVAL (QUOTE A) (QUOTE ((A VAL))))
                     "should be VAL.")                 

           '(println= (EVAL (QUOTE B)        
                           (QUOTE ((A  VAL1) (B VAL2) (C VAL3))))
                     "should be VAL2.")

           '(println= (EVAL (QUOTE (QUOTE A)) (QUOTE ((A VAL))))
                     "should be A.")

           '(println= (EVAL (QUOTE (ATOM (QUOTE A)) (QUOTE ((T1 T2)))))
                     "should be T.")

           '(println= (EVAL (QUOTE (ATOM A)) (QUOTE ((A VAL))))
                     "should be T.")   

           '(println= (EVAL (QUOTE (ATOM A)) (QUOTE ((A (VAL)))))
                     "should be F.")   

           '(println= (EVAL (QUOTE (EQ (QUOTE A) (QUOTE A))) (QUOTE NIL))
                     "should be T.")

           '(println= (EVAL (QUOTE (EQ (QUOTE A) (QUOTE B))) (QUOTE NIL))
                     "should be F.")

           '(println= (EVAL (QUOTE (EQ A B)) (QUOTE ((A Z)(B Z))))
                     "should be T.")

           '(println= (EVAL (QUOTE (EQ A B)) (QUOTE ((A Y)(B Z))))
                     "should be F.")

           '(println= (EVAL (QUOTE (COND ((QUOTE T) (QUOTE A))))
                           (QUOTE ((A HI))))
                     "should be A.")

           '(println= (EVAL (QUOTE (COND ((QUOTE F) (QUOTE A))
                                        ((QUOTE T) B)))
                           (QUOTE ((B HI))))
                     "should be HI.")
                           
           '(println= (EVAL (QUOTE (CAR (QUOTE ((A B) (C D)))))
                           (QUOTE ((A X))))
                     "should be (A . (B . NIL)).")
                           
           '(println= (EVAL (QUOTE (CDR (QUOTE ((A B) (C D)))))
                           (QUOTE ((A X))))
                     "should be ((C . (D . NIL)) . NIL).")

           '(println= (EVAL (QUOTE (CONS A (QUOTE B)))
                           (QUOTE ((A X) (B Y))))
                     "should be (X . B).")

           '(println= (EVAL (QUOTE V2)
                           (QUOTE ((V1 X) (V2 Y) (V3 Z))))
                     "should be Y.")

;---------------------------------------------------------------
; APPLY
;---------------------------------------------------------------

(define (APPLY f a)
  (EVAL (CONS f (APPQ a)) (QUOTE NIL)))

'(println (APPLY (QUOTE CONS) (QUOTE (A (B)))))


(println "Definition of McCarthy60 Lisp for Newlisp.")
(println "Kazimir Majorinc, 2010.")
(println "\nAvailable functions and operators: \n")

(println "AMONG, AND, APPEND, APPLY APPQ, ASSOC, ATOM, CAR, CDR, C...R,\n"
         "COND, CONS, EVAL, EQ, EQUAL, EVCON, EVLIS, FF, LABEL, LAMBDA, \n"
         "LIST, NOT, OR, PAIR, QUOTE, SUB2, SUBLIS, SUBST.\n\n"
         "listform, dotform, debug-wrap, debug-unwrap\n"
         
         "Can be used and combined with other Newlisp functions.")
         
(println "\n")

(dolist(i '(((listform (QUOTE (A . (B)))))
            ((dotform (QUOTE (A . (B)))))
            ((CONS (QUOTE (X Y)) (QUOTE (Y Z))))
            ((listform (CONS (QUOTE (X Y)) (QUOTE (Y Z)))))
            ((time (cons (quote (X Y Z)) (quote (Y Z V))) 10000))
            ((time (CONS (QUOTE (X Y Z)) (QUOTE (Y Z V))) 1000))
            ((time (EVAL (QUOTE (CONS (QUOTE (X Y Z)) (QUOTE (Y Z V))))) 100))
            ((debug-wrap CONS)
             (CONS (CONS (QUOTE (X Y)) (QUOTE NIL)) (QUOTE (Y Z))))
            ((debug-unwrap CONS)(CONS (QUOTE (X Y)) (QUOTE (Y Z))))))
   (println "            Example "
            (+ $idx 1) ". \n")
   (println "Evaluation of:\n")
   (dolist(j i)(println "   " j))
   (println "\nproduces output:\n")
   (local(k)
   (dolist(j i)
     (setf k (eval j)))
   (println "\nand result:\n")
   (println "   " k "\n-----------------------------------")))



If you liked this article, maybe the following article could interest you:


McCarthy-60 Lisp implemented as association list in McCarthy-60 Lisp.




--

1 comment:

  1. Jan Burse25 October 2011 at 01:11

    One more fallen giant: http://techcrunch.com/2011/10/24/creator-of-lisp-john-mccarthy-dead-at-84/

    ReplyDelete

Subscribe to: Post Comments (Atom)