Something almost Schemeish in something CLish.

I just wanted to see how much I could bang out in a single night without without referring to any documentation or previous code, and after having not even written anything in Common Lisp in 1.5 or 2 years. If I could have rememberd or bothered to look up more of CL’s standard lib and macros (like… iteration) this probably could have been done in a quarter of the time and space, but that wasn’t the point. Next up would be to implement define and revoke set!’s ability to create vars, making sure they scope correctly, and to add a list of primitives. But it’s time to go home. Maybe I’ll pick it up again tomorrow, maybe I won’t.

;Copyright (c) 2011 Matthew A. Martin (matt.a.martin@gmail.com)
;
;Permission is hereby granted, free of charge, to any person
;obtaining a copy of this software and associated documentation
;files (the "Software"), to deal in the Software without
;restriction, including without limitation the rights to use,
;copy, modify, merge, publish, distribute, sublicense, and/or sell
;copies of the Software, and to permit persons to whom the
;Software is furnished to do so, subject to the following
;conditions:
;
;The above copyright notice and this permission notice shall be
;included in all copies or substantial portions of the Software.
;
;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;OTHER DEALINGS IN THE SOFTWARE.
;;;;
; A scheme-flavored interpreter in a subset of Common Lisp.

(defconstant empty-stack nil)
(defconstant empty-frame nil)

;CL-USER> (frame (list 'a 'b 'c) (list 1 2 3) (frame (list 'd 'e 'f) (list 4 5 6) empty-frame))
;((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6))
(defun frame (vars vals frame)
  (if (null vars) frame
      (cons (cons (first vars) (first vals))
	    (frame (rest vars) (rest vals) frame))))

;CL-USER> (stack (frame (list 'a 'b 'c) (list 1 2 3) (frame (list 'd 'e 'f) (list 4 5 6) empty-frame)) empty-stack)
;(((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6)))
;CL-USER> (stack (frame (list 'a 'b 'c) (list 1 2 3) empty-frame) (stack (frame (list 'd 'e 'f) (list 4 5 6) empty-frame) empty-stack))
;(((A . 1) (B . 2) (C . 3)) ((D . 4) (E . 5) (F . 6)))
(defun stack (frame stack)
  (cons frame stack))

;CL-USER> (lookup-frame 'b (frame (list 'a 'b 'c) (list 1 2 3) empty-frame))
;(B . 2)
;CL-USER> (lookup-frame 'd (frame (list 'a 'b 'c) (list 1 2 3) empty-frame))
;NIL
(defun lookup-frame (var frame)
  (if (null frame) nil
      (if (eq var (first (first frame)))
          (first frame)
          (lookup-frame var (rest frame)))))

;CL-USER> (lookup 'a (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(A . 1)
;CL-USER> (lookup 'b (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(B . 2)
;CL-USER> (lookup 'c (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(C . 3)
;CL-USER> (lookup 'd (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;NIL
(defun lookup (var stack)
  (if (null stack) nil
      (let ((varp (lookup-frame var (first stack))))
        (if varp varp
            (lookup var (rest stack))))))

(defun value (x)
  (rest x))

(defun update (var val stack)
  (let ((varp (lookup var stack)))
    (if varp 
	(rplacd varp val)
	(rplaca stack (frame (list var)
			     (list val)
			     (first stack)))))) ; Exploiting (first nil) => nil here

;;; From here on, nothing should care that envs/stacks and frames are lists.

;; Helper for evaluate.
;CL-USER> (defvar tststk (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;TSTSTK
;CL-USER> (lookup-list (list 'a 'b 'c) tststk)
;(1 2 3)
;CL-USER> (lookup-list (list 'a 'b 'd 'c) tststk)
;(1 2 NIL 3)
(defun lookup-list (varlst stack)
  (if (null varlst) nil
      (cons (let ((varp (lookup (first varlst) stack)))
	      (if varp (value varp) varp))
	    (lookup-list (rest varlst) stack))))

;; Helper for evaluate.
(defun constant (x)
  (if (or (eq x t) (eq x nil) (numberp x))
      t
      nil))

;; Helper for evaluate.
;CL-USER> (func '((a b c) foo))
;(FN (A B C) (BEGIN FOO))
(defun func (args)
  (list 'fn ; tag 
	(first args) ; arg names 
	(cons 'begin ; implicit begin/progn
	      (rest args)))) ; fn body

;CL-USER> (fn-args (func '((a b c) foo)))
;(A B C)
(defun fn-args (x) (second x))

;CL-USER> (fn-body (func '((a b c) foo)))
;(BEGIN FOO)
(defun fn-body (x) (third x))

;; Helper for evaluate.
(defun eval-list (exps env)
  (if (null exps) nil
      (cons (evaluate (first exps) env)
	    (eval-list (rest exps) env))))

;; Helper for applier
(defun primitive? (x)
  (eq (first x) 'prim))
;; Helper for applier
(defun func? (x)
  (eq (first x) 'fn))

;CL-USER> (evaluate t tststk)
;T
;CL-USER> (evaluate '(if t b (quote bar)) tststk)
;2
;CL-USER> (evaluate '(if nil b (quote foo)) tststk)
;FOO
;CL-USER>  (evaluate '(begin 1 2 3 (eq? 2 2)) tststk)
;T
;CL-USER>  (evaluate '(set! a 4) tststk)
;(A . 4)
;CL-USER> tststk
;(((A . 4) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! d 4) tststk)
;(((D . 4) (A . 4) (B . 2)) ((C . 3)))
;CL-USER> tststk
;(((D . 4) (A . 4) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! a 5) tststk)
;(A . 5)
;CL-USER> tststk
;(((D . 4) (A . 5) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! a b) tststk)
;(A . 2)
;CL-USER> tststk
;(((D . 4) (A . 2) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! b 5) tststk)
;(B . 5)
;CL-USER> tststk
;(((D . 4) (A . 2) (B . 5)) ((C . 3)))
;CL-USER> (evaluate '(begin (set! foo (lambda (x) x)) (foo 1)) tststk)
;1
;CL-USER> (evaluate '(begin (set! bar (lambda (x) x)) (bar d)) tststk)
;4
;CL-USER> tststk
;(((BAR FN (X) (BEGIN X)) (FOO FN (X) (BEGIN X)) (D . 4) (A . 2) (B . 5)) ((C . 3)))
(defun evaluate (exp env)
  (cond
    ((constant exp) exp)
    ((symbolp exp) (rest (lookup exp env)))
    (t
     (let ((fn (first exp))
	   (args (rest exp)))
       (cond
	 ;; Special forms.
	 ((eq fn 'quote) (first args))
	 ((eq fn 'eq?) (eq (evaluate (first args) env) (evaluate (second args) env)))
	 ((eq fn 'if)
	  (let ((result (evaluate (first args) env)))
	    (if result
		(evaluate (second args) env)
		(evaluate (third args) env))))
	 ((eq fn 'lambda) (func args))
	 ((eq fn 'set!) ; or define
	  (update (first args) (evaluate (second args) env) env))
	 ((eq fn 'begin)
	  (if (eq 1 (length args))
	      (evaluate (first args) env)
	      ;; Borrow CL's progn here assuming it's iterative.
	      (progn (evaluate (first args) env)
		     (evaluate (cons 'begin (rest args)) env))))
	 (t (applier (evaluate fn env) (eval-list args env) env))))))) ; strict
	  
(defun applier (fn args env)
  (cond
    ((primitive? fn) (apply (second fn) args))
    ((func? fn) 
     (evaluate (fn-body fn)
	       (stack (frame (fn-args fn) args empty-frame)
		      env)))
    (t barf))) ; Shouldn't get here.

Happy new year!

Yeah, it’s a few days late. Oh well.

Havn’t really done shit as far as code lately other than work on reinventing yet another lists library for C to better grok the relation of lisp and implementation, and some playing around with hash tables.

In other news, I’ve got a temp blog running here.

Dude makes vids on Baguazhang, folks write about working with ‘em. I’ve already got gigs of vids and an entire shelf of books on such matter, but what the hell, I won’t turn down basically free shit.

Other than that, life’s a haze of eggnog between shifts at work.