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