fork download
copy 
  1. ; YourDSL - Can you evaluate this lazy S-expr?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 10
  5. ; Exercise 2
  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 first_ (l)
  13.   (cond
  14.    ((null l) '())
  15.    (t (car l))))
  16.  
  17. (defun second_ (l)
  18.   (cond
  19.    ((null l) '())
  20.    (t (car (cdr l)))))
  21.  
  22. (defun build (a b)
  23.   (cons a (cons b '())))
  24.  
  25. (setf e4
  26.      '(3 (quote a)(quote b)))
  27.  
  28. (defun atom-to-action (e)
  29.   (cond
  30.    ((numberp e) '*self-evaluating)
  31.    (t '*identifier)))
  32.  
  33. (defun list-to-action (e)
  34.   (cond
  35.    ((atom (car e))
  36.     (cond
  37.      ((eq (car e) (quote quote))
  38.       '*quote)
  39.      ((eq (car e) (quote lambda))
  40.       '*lambda)
  41.      ((eq (car e) (quote cond))
  42.       '*cond)
  43.      (t '*application)))
  44.    (t '*application)))
  45.  
  46. (defun expression-to-action (e)
  47.   (cond
  48.    ((atom e) (atom-to-action e))
  49.    (t (list-to-action e))))
  50.  
  51. (defun meaning (e table)
  52.   (funcall (expression-to-action e) e table))
  53.  
  54. (defun value_ (e)
  55.   (meaning e (quote ())))
  56.  
  57. (defun *self-evaluating (e table)
  58.   e)
  59.  
  60. (defun *quote (e table)
  61.       (text-of-quotation e))
  62.  
  63. (defun text-of-quotation (l) 
  64.   (second_ l))
  65.  
  66. (defun *identifier (e table)
  67.   (lookup-in-table
  68.    e table 'initial-table))
  69.  
  70. (defun initial-table (name)
  71.   (cond
  72.    ((eq name (quote t)) t)
  73.    ((eq name (quote nil)) nil)
  74.   (t (build 
  75.       (quote primitive)
  76.       name))))
  77.  
  78. (defun lookup-in-table (name table table-f)
  79.   (cond
  80.    ((null table) (funcall table-f name))
  81.    (t (lookup-in-entry
  82.        name
  83.        (car table)
  84.        (lambda (name)
  85.          (lookup-in-table
  86.           name
  87.           (cdr table)
  88.           table-f))))))
  89.  
  90. (defun lookup-in-entry (name entry entry-f)
  91.   (lookup-in-entry-help
  92.    name
  93.    (first_ entry)
  94.    (second_ entry)
  95.    entry-f))
  96.  
  97. (defun lookup-in-entry-help (name names values entry-f)
  98.   (cond
  99.    ((null names) (funcall entry-f name))
  100.    ((eq (car names) name)
  101.    (car values))
  102.   (t (lookup-in-entry-help
  103.       name
  104.       (cdr names)
  105.       (cdr values)
  106.       entry-f))))
  107.  
  108. (defun *application (e table)
  109.   (apply_
  110.    (meaning (function-of e) table)
  111.    (evlis (arguments-of e) table)))
  112.  
  113. (defun evcon (lines table)
  114.   (cond
  115.    ((meaning
  116.      (question-of (car lines)) table)
  117.     (meaning
  118.      (answer-of (car lines)) table))
  119.    (t (evcon (cdr lines) table))))
  120.  
  121. (defun question-of (l)
  122.   (first_ l))
  123.  
  124. (defun answer-of (l)
  125.   (second_ l))
  126.  
  127. (defun *cond (e table)
  128.   (evcon (cond-lines e) table))
  129.  
  130. (defun cond-lines (l) 
  131.   (cdr l))
  132.  
  133.  
  134. (defun apply_ (fun vals)
  135.   (cond
  136.    ((primitive? fun)
  137.     (apply-primitive
  138.      (second_ fun) vals))
  139.    ((non-primitive? fun)
  140.     (apply-closure
  141.      (second_ fun) vals))))
  142.  
  143. (defun primitive? (l)
  144.   (eq
  145.    (first_ l)
  146.    (quote primitive)))
  147.  
  148. (defun non-primitive? (l)
  149.   (eq
  150.    (first_ l)
  151.    (quote non-primitive)))
  152.  
  153. (defun add1 (n)
  154.   (+ 1 n))
  155.  
  156. (defun apply-primitive (name vals)
  157.   (cond
  158.    ((eq name (quote car))
  159.     (car (first_ vals)))
  160.    ((eq name (quote cdr))
  161.     (cdr (first_ vals)))
  162.    ((eq name (quote cons))
  163.     (cons (first_ vals) (second_ vals)))
  164.    ((eq name (quote eq))
  165.     (eq (first_ vals) (second_ vals)))
  166.    ((eq name (quote atom))
  167.     (atom (first_ vals) ))   
  168.    ((eq name (quote not))
  169.     (not (first_ vals) ))   
  170.    ((eq name (quote null))
  171.     (null (first_ vals) ))   
  172.    ((eq name (quote number))
  173.     (numberp (first_ vals) ))   
  174.    ((eq name (quote zero))
  175.     (zero (first_ vals) ))      
  176.    ((eq name (quote add1))
  177.     (add1 (first_ vals) ) )  
  178.    ((eq name (quote sub1))
  179.     (sub1 (first_ vals) )) ))
  180.  
  181. (defun function-of (l) 
  182.   (car l))
  183.  
  184. (defun arguments-of (l) 
  185.   (cdr l))
  186.  
  187. (defun evlis (args table)
  188.   (cond
  189.    ((null args) (quote ()))
  190.    (t (cons (meaning (car args) table)
  191.             (evlis (cdr args) table)))))
  192.  
  193. (defun apply-closure (closure vals)
  194.   (meaning (body-of closure)
  195.            (extend-table
  196.             (new-entry
  197.              (formals-of closure) vals)
  198.             (table-of closure))))
  199.  
  200. (defun body-of (l)
  201.   (third l))
  202.  
  203. (defun extend-table (a b)
  204.   (cons a b))
  205.  
  206. (defun new-entry (a b)
  207.   (build a b))
  208.  
  209. (defun formals-of (l)
  210.   (second_ l))
  211.  
  212. (defun table-of (l)
  213.   (first_ l))
  214.  
  215. (defun *lambda (e table)
  216.   (build (quote non-primitive)
  217.          (cons table (cdr e))))
  218.  
  219. ; ------------------------------
  220. (setf e1
  221.        '((lambda (x)
  222.           (cond
  223.            ((atom x)(quote 'done))
  224.            ((null x)(quote 'almost))
  225.            (t (quote 'never))))
  226.          (quote (add1 1)))) ; where '(add1 1) is the inserted s-expr
  227.  
  228. (setf e1
  229.        '((lambda (x)
  230.           (cond
  231.            ((atom x)(quote 'done))
  232.            ((null x)(quote 'almost))
  233.            (t (quote 'never))))
  234.            (quote x))) ; where '(add1 1) is the inserted s-expr
  235.  
  236. (print (value_ e1))
  237. ;'DONE
  238.  
  239. (print (lookup-in-table 't '() 'initial-table))
  240. ;T
  241.  
  242.  
  243.  
Success #stdin #stdout 0s 10648KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
'DONE 
T
https://ideone.com/h4eEM
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!