fork download
copy 
  1. ; YourDSL - How to rewrite closures and primitives
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 10
  5. ; Exercise 5
  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. (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. (initial-table 'bob)
  212. ; (primitive bob)
  213. ; hint from 10.6 that initial-table needs to be represented as functions...
  214.  
  215. (defun initial-table (name)
  216.   (cond
  217.    ((eq name (quote t)) t)
  218.    ((eq name (quote nil)) nil)
  219.   (t (build 
  220.       (quote primitive)
  221.       name))))
  222.  
  223. (initial-table 'bob)
  224. ; (primitive bob)
  225.  
  226. ; possible to rewrite this to be a stream of functions
  227.  
  228. ;1. value
  229. (print (value_ '(add1 1)) )
  230. ;=> 2
  231.  
  232. ;2. -meaning
  233. (meaning '(add1 1) '()) 
  234. ; 2
  235.  
  236. ;3. -meaning
  237. (expression-to-action '(add1 1)) 
  238. ; *application
  239.  
  240. ;4.-meaning
  241. (funcall '*application '(add1 1) '()) 
  242. ; 2
  243.  
  244. ;5 -application
  245. (function-of '(add1 1)) 
  246. ; ADD1
  247.  
  248. ;6. -application
  249. (meaning 'add1 '()) 
  250. ; (primitive add1)
  251.  
  252. ;7. -application
  253. (arguments-of '(add1 1)) 
  254. ; (1)
  255.  
  256. ;8. -application
  257. (evlis '(1) '()) 
  258. ; (1)
  259.  
  260. ;9. -application
  261. (apply_ '(primitive add1) '(1)) 
  262. ; 2
  263.  
  264. (print (value_ '((lambda (x) (add1 x)) 2)))
  265. ; 3
  266.  
  267. ;(print (value_ e3))
  268. ; 6
  269.  
  270. (setf e3_
  271.      '((lambda (x)
  272.          (add1 4))
  273.        6))
  274.  
  275. (print (value_ e3_) )
  276. ; 5
  277.  
  278. (setf e3__
  279.      '((lambda (x)
  280.          (add1 x))
  281.        6))
  282.  
  283. (print (value_ e3__))
  284. ; 7
  285.  
  286. ;1. value
  287. (print (value_ '((lambda (x) (add1 x)) 6)))
  288. ; 7
  289.  
  290. ;2. meaning
  291. (meaning '((lambda (x) (add1 x)) 6) '())
  292. ; 7
  293.  
  294. ;3. -meaning
  295. (expression-to-action '((lambda (x) (add1 x)) 6)) 
  296. ; *application
  297.  
  298. ;4.-meaning
  299. (funcall '*application '((lambda (x) (add1 x)) 6) '()) 
  300. ; 7
  301.  
  302. ;5 -application
  303. (function-of '((lambda (x) (add1 x)) 6)) 
  304. ; (LAMBDA (X) (ADD1 X))
  305.  
  306. ;6. -application
  307. (meaning '(LAMBDA (X) (ADD1 X)) '()) 
  308. ;(NON-PRIMITIVE (NIL (X) (ADD1 X)))
  309.  
  310. ;7. -application
  311. (arguments-of '((lambda (x) (add1 x)) 6)) 
  312. ; (6)
  313.  
  314. ;8. -application
  315. (evlis '(6) '()) 
  316. ; (6)
  317.  
  318. ;9. -application
  319. (apply_ '(NON-PRIMITIVE (NIL (X) (ADD1 X))) '(6)) 
  320. ; 7
  321.  
  322.  
  323. (meaning '(lambda)  '())
  324. ;1. Basically the goal is to rewrite the __apply__ function so that the primitive and 
  325. ;non-primitive tags are no longer needed
  326. ;2. The tags come from the __meaning__ function inside the __application__ function
  327. ;3. Need to rewrite the __initial-table__ function with the  __meaning__ function to stop adding primitive and non-primitive flags
  328. ;4. Need to rewrite __apply__ so that it simply applies 'non-primitive to lambda functions
  329. ;   and applies primitive to everything else
  330. ;5. And change __*lambda__ function not to return non-pritimive
  331.  
  332. ;So __initial-table__ changes from
  333.  
  334. (defun initial-table (name)
  335.   (cond
  336.    ((eq name (quote t)) t)
  337.    ((eq name (quote nil)) nil)
  338.   (t (build 
  339.       (quote primitive)
  340.       name))))
  341. ;to
  342. (defun initial-table5 (name)
  343.   (cond
  344.    ((eq name (quote t)) t)
  345.    ((eq name (quote nil)) nil)
  346.    (t (cons name '()))))
  347.  
  348. (initial-table 'bob)
  349. ;(PRIMITIVE BOB)
  350.  
  351. (initial-table5 'bob)
  352. ;(BOB)
  353.  
  354. ;and lambda becomes
  355. (defun *lambda (e table)
  356.   (build (quote non-primitive)
  357.          (cons table (cdr e))))
  358.  
  359. (defun *lambda5 (e table)
  360.   (cons (cons table (cdr e)) '()))
  361.  
  362. (*lambda '(boris) '())
  363. ; (NON-PRIMITIVE (NIL))
  364.  
  365. (*lambda5 '(boris) '())
  366. ; ((NIL))
  367.  
  368. (defun list-to-action5 (e)
  369.   (cond
  370.    ((atom (car e))
  371.     (cond
  372.      ((eq (car e) (quote quote))
  373.       '*quote)
  374.      ((eq (car e) (quote lambda))
  375.       '*lambda5)
  376.      ((eq (car e) (quote cond))
  377.       '*cond)
  378.      (t '*application5)))
  379.    (t '*application5)))
  380.  
  381. (defun expression-to-action5 (e)
  382.   (cond
  383.    ((atom e) (atom-to-action5 e))
  384.    (t (list-to-action5 e))))
  385.  
  386. (defun meaning5 (e table)
  387.   (funcall (expression-to-action5 e) e table))
  388.  
  389. (defun value5 (e)
  390.   (meaning5 e (quote ())))
  391.  
  392. (defun *identifier5 (e table)
  393.   (lookup-in-table
  394.    e table 'initial-table5))
  395.  
  396. (defun atom-to-action5 (e)
  397.   (cond
  398.    ((numberp e) '*self-evaluating)
  399.    (t '*identifier5)))
  400.  
  401. (defun apply5 (fun vals)
  402.   (cond
  403.    ((not (eq 'lambda (car fun)))
  404.     (apply-primitive
  405.      (second fun) vals))
  406.    ((eq 'lambda (car fun))
  407.     (apply-closure
  408.      (second fun) vals))))
  409.  
  410. (defun *application5 (e table)
  411.   (apply5
  412.    (meaning (function-of e) table)
  413.    (evlis (arguments-of e) table)))
  414.  
  415. (print (value5 '(add1 1)))
  416. ;2
  417.  
  418. (print (value5 '((lambda (x) (add1 x)) 6)))
  419. ; NIL
  420.  
  421.  
  422.  
  423.  
  424.  
Success #stdin #stdout 0.01s 10680KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
2 
3 
5 
7 
7 
2 
NIL
https://ideone.com/yjhRY
language:
Common Lisp (clisp 2.49.92)
created:
14 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!