fork download
copy 
  1. ; YourDSL - How to rewrite your function
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 10
  5. ; Exercise 4
  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.  
  48. (defun *self-evaluating (e table)
  49.   e)
  50.  
  51. (defun *quote (e table)
  52.       (text-of-quotation e))
  53.  
  54. (defun text-of-quotation (l) 
  55.   (second l))
  56.  
  57. (defun *identifier (e table)
  58.   (lookup-in-table
  59.    e table 'initial-table))
  60.  
  61. (defun initial-table (name)
  62.   (cond
  63.    ((eq name (quote t)) t)
  64.    ((eq name (quote nil)) nil)
  65.   (t (build 
  66.       (quote primitive)
  67.       name))))
  68.  
  69. (defun lookup-in-table (name table table-f)
  70.   (cond
  71.    ((null table) (funcall table-f name))
  72.    (t (lookup-in-entry
  73.        name
  74.        (car table)
  75.        (lambda (name)
  76.          (lookup-in-table
  77.           name
  78.           (cdr table)
  79.           table-f))))))
  80.  
  81. (defun lookup-in-entry (name entry entry-f)
  82.   (lookup-in-entry-help
  83.    name
  84.    (first entry)
  85.    (second entry)
  86.    entry-f))
  87.  
  88. (defun lookup-in-entry-help (name names values entry-f)
  89.   (cond
  90.    ((null names) (funcall entry-f name))
  91.    ((eq (car names) name)
  92.    (car values))
  93.   (t (lookup-in-entry-help
  94.       name
  95.       (cdr names)
  96.       (cdr values)
  97.       entry-f))))
  98.  
  99. (defun *application (e table)
  100.   (apply_
  101.    (meaning (function-of e) table)
  102.    (evlis (arguments-of e) table)))
  103.  
  104. (defun evcon (lines table)
  105.   (cond
  106.    ((meaning
  107.      (question-of (car lines)) table)
  108.     (meaning
  109.      (answer-of (car lines)) table))
  110.    (t (evcon (cdr lines) table))))
  111.  
  112. (defun question-of (l)
  113.   (first l))
  114.  
  115. (defun answer-of (l)
  116.   (second l))
  117.  
  118. (defun *cond (e table)
  119.   (evcon (cond-lines e) table))
  120.  
  121. (defun cond-lines (l) 
  122.   (cdr l))
  123.  
  124.  
  125. (defun apply_ (fun vals)
  126.   (cond
  127.    ((primitive? fun)
  128.     (apply-primitive
  129.      (second fun) vals))
  130.    ((non-primitive? fun)
  131.     (apply-closure
  132.      (second fun) vals))))
  133.  
  134. (defun primitive? (l)
  135.   (eq
  136.    (first l)
  137.    (quote primitive)))
  138.  
  139. (defun non-primitive? (l)
  140.   (eq
  141.    (first l)
  142.    (quote non-primitive)))
  143.  
  144. (defun add1 (n)
  145.   (+ 1 n))
  146.  
  147. (defun apply-primitive (name vals)
  148.   (cond
  149.    ((eq name (quote car))
  150.     (car (first vals)))
  151.    ((eq name (quote cdr))
  152.     (cdr (first vals)))
  153.    ((eq name (quote cons))
  154.     (cons (first vals) (second vals)))
  155.    ((eq name (quote eq))
  156.     (eq (first vals) (second vals)))
  157.    ((eq name (quote atom))
  158.     (atom (first vals) ))   
  159.    ((eq name (quote not))
  160.     (not (first vals) ))   
  161.    ((eq name (quote null))
  162.     (null (first vals) ))   
  163.    ((eq name (quote number))
  164.     (numberp (first vals) ))   
  165.    ((eq name (quote zero))
  166.     (zero (first vals) ))      
  167.    ((eq name (quote add1))
  168.     (add1 (first vals) ) )  
  169.    ((eq name (quote sub1))
  170.     (sub1 (first vals) )) ))
  171.  
  172. (defun function-of (l) 
  173.   (car l))
  174.  
  175. (defun arguments-of (l) 
  176.   (cdr l))
  177.  
  178. (defun evlis (args table)
  179.   (cond
  180.    ((null args) (quote ()))
  181.    (t (cons (meaning (car args) table)
  182.             (evlis (cdr args) table)))))
  183.  
  184. (defun apply-closure (closure vals)
  185.   (meaning (body-of closure)
  186.            (extend-table
  187.             (new-entry
  188.              (formals-of closure) vals)
  189.             (table-of closure))))
  190.  
  191. (defun body-of (l)
  192.   (third l))
  193.  
  194. (defun extend-table (a b)
  195.   (cons a b))
  196.  
  197. (defun new-entry (a b)
  198.   (build a b))
  199.  
  200. (defun formals-of (l)
  201.   (second l))
  202.  
  203. (defun table-of (l)
  204.   (first l))
  205.  
  206. (defun *lambda (e table)
  207.   (build (quote non-primitive)
  208.          (cons table (cdr e))))
  209.  
  210. ; ------------------------------
  211.  
  212. (setf e3
  213.      '((lambda (x)
  214.         ((lambda (x)
  215.            (add1 x))
  216.          (add1 4)))
  217.        6))
  218.  
  219. (print (value_ e3))
  220. ; 6
  221. ; Its doing 4 + 1 = 5 then passing that to add1 -  the final 6 is ignored
  222. ; from the first lambda - you can change the 6 to -1 and get the same value
  223.  
  224. ;stepping through
  225. (meaning e3 '())
  226. ;6
  227.  
  228. (expression-to-action e3)
  229. ;*APPLICATION
  230.  
  231. (*application e3 '())
  232. ;6
  233.  
  234. (meaning (function-of e3) '())
  235. ; (NON-PRIMITIVE (NIL (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4))))
  236.  
  237. (evlis (arguments-of e3) '())
  238. ; (6)
  239.  
  240. (apply_ '(NON-PRIMITIVE (NIL (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4)))) '(6))
  241. ; 6
  242.  
  243. (function-of e3)
  244. ; (LAMBDA (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4)))
  245.  
  246. (meaning '(LAMBDA (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4))) '())
  247. ; (NON-PRIMITIVE (NIL (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4))))
  248.  
  249. (expression-to-action '(LAMBDA (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4))) )
  250. ; *LAMBDA
  251.  
  252. (funcall '*LAMBDA '(LAMBDA (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4))) '())
  253. ; (NON-PRIMITIVE (NIL (X) ((LAMBDA (X) (ADD1 X)) (ADD1 4)))) ?
  254.  
  255.  
  256.  
  257.  
Success #stdin #stdout 0.01s 10648KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
6
https://ideone.com/7TnpO
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!