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