fork download
copy 
  1.  
  2. ; YourDSL - Is this S-Expr a lambda-expression?
  3. ; ------------------------------
  4. ; The Little Lisper 3rd Edition
  5. ; Chapter 10
  6. ; Exercise 7
  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 build (a b)
  14.   (cons a (cons b '())))
  15.  
  16. (setf e4
  17.      '(3 (quote a)(quote b)))
  18.  
  19. (defun atom-to-action (e)
  20.   (cond
  21.    ((numberp e) '*self-evaluating)
  22.    (t '*identifier)))
  23.  
  24. (defun list-to-action (e)
  25.   (cond
  26.    ((atom (car e))
  27.     (cond
  28.      ((eq (car e) (quote quote))
  29.       '*quote)
  30.      ((eq (car e) (quote lambda))
  31.       '*lambda)
  32.      ((eq (car e) (quote cond))
  33.       '*cond)
  34.      (t '*application)))
  35.    (t '*application)))
  36.  
  37. (defun expression-to-action (e)
  38.   (cond
  39.    ((atom e) (atom-to-action e))
  40.    (t (list-to-action e))))
  41.  
  42. (defun meaning (e table)
  43.   (funcall (expression-to-action e) e table))
  44.  
  45. (defun value_ (e)
  46.   (meaning e (quote ())))
  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. (defun *lambda? (x)
  213.   (and
  214.    (eq (car x) 'lambda)
  215.    (eq (count-lat x) 3)))
  216.  
  217. (defun count-lat (vec)
  218.   (cond
  219.    ((null vec) 0)
  220.    (t  (+ 1 (count-lat (cdr vec))))))
  221.  
  222.  
  223.  
  224. (setf e5 
  225.   '(lambda (lat) (cons (quote lat) 'lat)))
  226.  
  227. (count-lat e5)
  228. ; 3
  229.  
  230. (setf e6
  231.   '(lambda (lat (lyst)) a (quote b)))
  232.  
  233. (setf e2
  234.      '(((lambda (x y)
  235.          (lambda (u)
  236.            (cond
  237.             (funcall u x)
  238.             (t y))))
  239.        1 ())
  240.        nil))
  241.  
  242. (print (*lambda? e5))
  243. ;T
  244.  
  245. (print (*lambda? e6))
  246. ;NIL false
  247.  
  248. (print (*lambda? e2))
  249. ;NIL false
  250.  
  251.  
  252.  
Success #stdin #stdout 0.01s 10648KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
T 
NIL 
NIL
https://ideone.com/WejGx
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!