fork download
copy 
  1. ; Can you change a function-table to a function?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 10
  5. ; Exercise 8
  6. ; Common Lisp
  7. ; http://t...content-available-to-author-only...r.com/thelittlelisper
  8. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper-chapter-10-what-is-value.html
  9. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper.html
  10. ; ------------------------------
  11.  
  12. (defun build (a b)
  13.   (cons a (cons b '())))
  14.  
  15. (setf e4
  16.      '(3 (quote a)(quote b)))
  17.  
  18. (defun atom-to-action (e)
  19.   (cond
  20.    ((numberp e) '*self-evaluating)
  21.    (t '*identifier)))
  22.  
  23. (defun list-to-action (e)
  24.   (cond
  25.    ((atom (car e))
  26.     (cond
  27.      ((eq (car e) (quote quote))
  28.       '*quote)
  29.      ((eq (car e) (quote lambda))
  30.       '*lambda)
  31.      ((eq (car e) (quote cond))
  32.       '*cond)
  33.      (t '*application)))
  34.    (t '*application)))
  35.  
  36. (defun expression-to-action (e)
  37.   (cond
  38.    ((atom e) (atom-to-action e))
  39.    (t (list-to-action e))))
  40.  
  41. (defun meaning (e table)
  42.   (funcall (expression-to-action e) e table))
  43.  
  44. (defun value_ (e)
  45.   (meaning e (quote ())))
  46.  
  47. (defun *self-evaluating (e table)
  48.   e)
  49.  
  50. (defun *quote (e table)
  51.       (text-of-quotation e))
  52.  
  53. (defun text-of-quotation (l) 
  54.   (second l))
  55.  
  56. (defun *identifier (e table)
  57.   (lookup-in-table
  58.    e table 'initial-table))
  59.  
  60. (defun initial-table (name)
  61.   (cond
  62.    ((eq name (quote t)) t)
  63.    ((eq name (quote nil)) nil)
  64.   (t (build 
  65.       (quote primitive)
  66.       name))))
  67.  
  68. (defun lookup-in-table (name table table-f)
  69.   (cond
  70.    ((null table) (funcall table-f name))
  71.    (t (lookup-in-entry
  72.        name
  73.        (car table)
  74.        (lambda (name)
  75.          (lookup-in-table
  76.           name
  77.           (cdr table)
  78.           table-f))))))
  79.  
  80. (defun lookup-in-entry (name entry entry-f)
  81.   (lookup-in-entry-help
  82.    name
  83.    (first entry)
  84.    (second entry)
  85.    entry-f))
  86.  
  87. (defun lookup-in-entry-help (name names values entry-f)
  88.   (cond
  89.    ((null names) (funcall entry-f name))
  90.    ((eq (car names) name)
  91.    (car values))
  92.   (t (lookup-in-entry-help
  93.       name
  94.       (cdr names)
  95.       (cdr values)
  96.       entry-f))))
  97.  
  98. (defun *application (e table)
  99.   (apply_
  100.    (meaning (function-of e) table)
  101.    (evlis (arguments-of e) table)))
  102.  
  103. (defun evcon (lines table)
  104.   (cond
  105.    ((meaning
  106.      (question-of (car lines)) table)
  107.     (meaning
  108.      (answer-of (car lines)) table))
  109.    (t (evcon (cdr lines) table))))
  110.  
  111. (defun question-of (l)
  112.   (first l))
  113.  
  114. (defun answer-of (l)
  115.   (second l))
  116.  
  117. (defun *cond (e table)
  118.   (evcon (cond-lines e) table))
  119.  
  120. (defun cond-lines (l) 
  121.   (cdr l))
  122.  
  123.  
  124. (defun apply_ (fun vals)
  125.   (cond
  126.    ((primitive? fun)
  127.     (apply-primitive
  128.      (second fun) vals))
  129.    ((non-primitive? fun)
  130.     (apply-closure
  131.      (second fun) vals))))
  132.  
  133. (defun primitive? (l)
  134.   (eq
  135.    (first l)
  136.    (quote primitive)))
  137.  
  138. (defun non-primitive? (l)
  139.   (eq
  140.    (first l)
  141.    (quote non-primitive)))
  142.  
  143. (defun add1 (n)
  144.   (+ 1 n))
  145.  
  146. (defun apply-primitive (name vals)
  147.   (cond
  148.    ((eq name (quote car))
  149.     (car (first vals)))
  150.    ((eq name (quote cdr))
  151.     (cdr (first vals)))
  152.    ((eq name (quote cons))
  153.     (cons (first vals) (second vals)))
  154.    ((eq name (quote eq))
  155.     (eq (first vals) (second vals)))
  156.    ((eq name (quote atom))
  157.     (atom (first vals) ))   
  158.    ((eq name (quote not))
  159.     (not (first vals) ))   
  160.    ((eq name (quote null))
  161.     (null (first vals) ))   
  162.    ((eq name (quote number))
  163.     (numberp (first vals) ))   
  164.    ((eq name (quote zero))
  165.     (zero (first vals) ))      
  166.    ((eq name (quote add1))
  167.     (add1 (first vals) ) )  
  168.    ((eq name (quote sub1))
  169.     (sub1 (first vals) )) ))
  170.  
  171. (defun function-of (l) 
  172.   (car l))
  173.  
  174. (defun arguments-of (l) 
  175.   (cdr l))
  176.  
  177. (defun evlis (args table)
  178.   (cond
  179.    ((null args) (quote ()))
  180.    (t (cons (meaning (car args) table)
  181.             (evlis (cdr args) table)))))
  182.  
  183. (defun apply-closure (closure vals)
  184.   (meaning (body-of closure)
  185.            (extend-table
  186.             (new-entry
  187.              (formals-of closure) vals)
  188.             (table-of closure))))
  189.  
  190. (defun body-of (l)
  191.   (third l))
  192.  
  193. (defun extend-table (a b)
  194.   (cons a b))
  195.  
  196. (defun new-entry (a b)
  197.   (build a b))
  198.  
  199. (defun formals-of (l)
  200.   (second l))
  201.  
  202. (defun table-of (l)
  203.   (first l))
  204.  
  205. (defun *lambda (e table)
  206.   (build (quote non-primitive)
  207.          (cons table (cdr e))))
  208.  
  209. ; ----------------------
  210.  
  211.  
  212. ;old definition
  213. (defun *lambda (e table)
  214. ;  (print '--*lambda--)
  215. ;  (print e)
  216. ;  (print table)
  217.   (build (quote non-primitive)
  218.          (cons table (cdr e))))
  219.  
  220. ;new definition
  221. (defun *lambda8 (e table)
  222.   (build
  223.    (quote non-primitive)
  224.    (lambda (vals)
  225.      (meaning (body-of e)
  226.               (extend-table
  227.                (new-entry (formals-of e) vals)
  228.                table)))))
  229.  
  230. ;1. Find out what *lambda function is called with (adding print statements to lambda function
  231. (value_ '((lambda (x) (add1 x)) 12))
  232. ;--APPLY-CLOSURE-- 
  233. ;(NIL (X) (ADD1 X)) 
  234. ;(12) 
  235. ;13
  236.  
  237. ;2. Try to see if arguments can be passed to function
  238. (*lambda '(lambda (x) (add1 x)) '())
  239. ;(NON-PRIMITIVE (NIL (X) (ADD1 X)))
  240.  
  241. ;3. Try passing arguments to new function
  242. (*lambda8 '(lambda (x) (add1 x)) '())
  243. ;(NON-PRIMITIVE #<Interpreted Closure (:INTERNAL *LAMBDA8) @ #x20eeb09a>)
  244.  
  245. (cdr (*lambda8 '(lambda (x) (add1 x)) '()))
  246. ;(#<Interpreted Closure (:INTERNAL *LAMBDA8) @ #x20f6769a>)
  247.  
  248. (car (cdr (*lambda8 '(lambda (x) (add1 x)) '())))
  249. ;#<Interpreted Closure (:INTERNAL *LAMBDA8) @ #x20f70e7a>
  250.  
  251. (funcall (car (cdr (*lambda8 '(lambda (x) (add1 x)) '()))) '(12))
  252. ; 13
  253.  
  254. ;4 So we need to modify what calls lambda to be like this
  255. (defun meaning8 (e table)
  256.   (funcall (expression-to-action e) e table))
  257.  
  258. (defun list-to-action8 (e)
  259.   (cond
  260.    ((atom (car e))
  261.     (cond
  262.      ((eq (car e) (quote quote))
  263.       '*quote)
  264.      ((eq (car e) (quote lambda))
  265.       '*lambda8)
  266.      ((eq (car e) (quote cond))
  267.       '*cond)
  268.      (t '*application)))
  269.    (t '*application)))
  270.  
  271. (defun expression-to-action8 (e)
  272.   (cond
  273.    ((atom e) (atom-to-action e))
  274.    (t (list-to-action8 e))))
  275.  
  276. (defun meaning8 (e table);funcall here?
  277.   (funcall (expression-to-action8 e) e table))
  278.  
  279. (defun value8 (e)
  280.   (meaning8 e (quote ())))
  281.  
  282. (print (value8 '(add1 1)))
  283. ;2
  284.  
  285. (print (value_ '((lambda (x) (add1 x)) 12)))
  286. ; 13
  287.  
  288. ;(value5 '((lambda (x) (add1 x)) 12))
  289. ; NIL
  290.  
  291. (print (value8 '((lambda (x) (add1 x)) 12)))
  292. ;13
  293.  
Success #stdin #stdout 0.01s 10656KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
2 
13 
13
https://ideone.com/pNVcF
language:
Common Lisp (clisp 2.49.92)
created:
13 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!