fork download
copy 
  1. ; YourDSL - Can you completely rewrite lisp in your DSL?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 10
  5. ; Exercise 10
  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. (defun *if (e table)
  212.       (if (meaning (test-pt e) table)
  213.           (meaning (then-pt e) table)
  214.         (meaning (else-pt e) table)))
  215.  
  216. (defun test-pt (list)
  217.   (second list))
  218.  
  219. (defun then-pt (list)
  220.   (third list))
  221.  
  222. (defun else-pt (list)
  223.   (fourth list))
  224.  
  225. (fourth (list 1 2 3 4))
  226. ; 4
  227.  
  228. (test-pt '(add1 1))
  229.  
  230. (defun list-to-action10 (e)
  231.   (cond
  232.    ((atom (car e))
  233.     (cond
  234.      ((eq (car e) (quote quote))
  235.       '*quote)
  236.      ((eq (car e) (quote lambda))
  237.       '*lambda)
  238.      ((eq (car e) (quote if))
  239.       '*if)
  240.      (t '*application)))
  241.    (t '*application)))
  242.  
  243. (defun expression-to-action10 (e)
  244.   (cond
  245.    ((atom e) (atom-to-action e))
  246.    (t (list-to-action10 e))))
  247.  
  248. (defun meaning10 (e table)
  249.   (funcall (expression-to-action10 e) e table))
  250.  
  251. (defun value10 (e)
  252.   (meaning10 e (quote ())))
  253.  
  254. (if (eq 1 2) ('nonNormal) )
  255. ; NIL false
  256.  
  257. (if (eq 1 2) ('nonNormal) 'normal)
  258. ; NORMAL
  259.  
  260.  
  261.  
  262. (print (value10 '(if (eq 1 2) ('nonNormal) 'normal)))
  263.  
  264.  
Success #stdin #stdout 0.01s 10656KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
NORMAL
https://ideone.com/1RNUz
language:
Common Lisp (clisp 2.49.92)
created:
14 years ago
visibility:
secret

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!