fork(2) download
copy 
  1. ; YourDSL - Can you represent a table as a fn?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 10
  5. ; Exercise 6
  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 list-to-action (e)
  19.   (cond
  20.    ((atom (car e))
  21.     (cond
  22.      ((eq (car e) (quote quote))
  23.       '*quote)
  24.      ((eq (car e) (quote lambda))
  25.       '*lambda)
  26.      ((eq (car e) (quote cond))
  27.       '*cond)
  28.      (t '*application)))
  29.    (t '*application)))
  30.  
  31. (defun atom-to-action (e)
  32.   (cond
  33.    ((numberp e) '*self-evaluating)
  34.    (t '*identifier)))
  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. (defun extend-table6 (entry table)
  213.   (lambda (name)
  214.     (cond
  215.      ((member name (first entry))
  216.       (pick (index name (first entry))
  217.             (second entry)))
  218.      (t (funcall table name)))))
  219.  
  220. (extend-table '(a b) '())
  221. ; ((A B))
  222.  
  223. (extend-table6 '(a b) '())
  224. ; #<Interpreted Closure...
  225.  
  226.  
  227. ;Working through use of extend table
  228. ;1. Value of a lambda
  229. (print (value_ '((lambda (x) (add1 x)) 6)))
  230. ; NIL
  231.  
  232. ;2. Calls apply-closure
  233. (apply-closure '(NIL (X) (ADD1 X)) '(6))
  234. ; 7
  235.  
  236. ;3 Calls extend-table with these values
  237. (defun apply-closure (closure vals)
  238.   (print '--apply-closure--)
  239.   (print closure)
  240.   (print vals)
  241.   (meaning (body-of closure)
  242.            (extend-table
  243.             (new-entry
  244.              (formals-of closure) vals)
  245.             (table-of closure))))
  246.  
  247. ;4. Formals-of simplifies to
  248. (formals-of '(NIL (X) (ADD1 X))) 
  249. ; (X)
  250.  
  251. ;5. table-of simplifies to 
  252. (table-of '(NIL (X) (ADD1 X))) 
  253. ; NIL
  254.  
  255. ;6. new entry becomes
  256. (new-entry
  257.  '(x) '(6)) 
  258. ; ((X) (6))
  259.  
  260. ;7. extend-table becomes
  261. (extend-table '((X) (6)) NIL) 
  262. ; (((X)(6)))
  263.  
  264. ;So our new function gives
  265. (extend-table6 '((X) (6)) NIL)
  266. ; #<Interpreted Closure
  267.  
  268.  
  269. (defun apply-closure6 (closure vals)
  270.   (print '--apply-closure--)
  271.   (print closure)
  272.   (print vals)
  273.   (meaning6 (body-of closure)
  274.            (extend-table
  275.             (new-entry
  276.              (formals-of closure) vals)
  277.             (table-of closure))))
  278.  
  279. (defun meaning6 (e table)
  280.   (funcall (expression-to-action e) e table))
  281.  
  282. (defun expression-to-action6 (e)
  283.   (cond
  284.    ((atom e) (atom-to-action6 e))
  285.    (t (list-to-action e))))
  286.  
  287. (defun atom-to-action6 (e)
  288.   (cond
  289.    ((numberp e) '*self-evaluating)
  290.    (t '*identifier6)))
  291.  
  292. (defun *identifier6 (e table)
  293.   (lookup-in-table6
  294.    e table 'initial-table))
  295.  
  296. (defun lookup-in-table6 (name table table-f)
  297.   (cond
  298.    ((null table) (funcall table-f name))
  299.    (t (lookup-in-entry
  300.        name
  301.        (car table)
  302.        (lambda (name)
  303.          (lookup-in-table6
  304.           name
  305.           ;(cdr table)
  306.           (car (funcall (cdr table)));!!!
  307.           table-f))))))
  308.  
  309. (defun value6 (e)
  310.   (meaning6 e (quote ())))
  311.  
  312. (print (value6 '(add1 12)))
  313. ; 13
  314.  
Success #stdin #stdout 0.01s 10664KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
7 
13
https://ideone.com/Vbz7V
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!