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