From: HB
Subject: essentials of programming languages in common lisp
Date: 
Message-ID: <1117890186.443719.299450@g47g2000cwa.googlegroups.com>
Hei,

I started reading "Essentials of Programming Languages" by Friedman,
Wand and Haynes. I wanted to implement the examples and the source of
the book in in CL, mainly because I like the
Emacs-Slime-SBCL-Combination. For SICP that was no big problem. Problem
in this case is, the book extensively uses a define-datatype macro
(which is actually quite cool) that is defined using syntax-case.
Porting define-datatype in a reasonable amount of time unfortunately is
way beyond my capabilities. Does anyone know if someone already
implemented something like define-datatype? Or has CL something similar
and I'm just too stupid to find it in the docs?

Greetings HB
From: O-MY-GLIFE
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <1117924446.606013.231030@g44g2000cwa.googlegroups.com>
HB wrote:
> Hei,
>
> I started reading "Essentials of Programming Languages" by Friedman,
> Wand and Haynes. I wanted to implement the examples and the source of
> the book in in CL, mainly because I like the
> Emacs-Slime-SBCL-Combination. For SICP that was no big problem. Problem
> in this case is, the book extensively uses a define-datatype macro
> (which is actually quite cool) that is defined using syntax-case.
> Porting define-datatype in a reasonable amount of time unfortunately is
> way beyond my capabilities. Does anyone know if someone already
> implemented something like define-datatype? Or has CL something similar
> and I'm just too stupid to find it in the docs?
>
> Greetings HB

I've done something of the kind for the "Programming Languages:
Application and Interpretation" of Shriram Krisnamurti. First I was
using defsctruct and deftype for creation of the datatypes and typecase
for dispatching on them

(deftype expr () '(or number add sub ...))

;; Records which are subtypes of EXPR
(defstruct add
  (lhs nil :type expr)
  (rhs nil :type expr))
(defstruct sub
  (lhs nil :type expr)
  (rhs nil :type expr))

;; using them
(typecase expr
  (add (..(add-lhs expr) ..)
  (sub (..(sub-lhs expr) ..)
  ..)

Later on I have written a couple of macros defrecord and ematch. Now i
have

(deftype expr ()
  '(or number add sub symbol if0 with  fun app bindcc))

(defrecord add (lhs expr) (rhs expr))
(defrecord sub (lhs expr) (rhs expr))
(defrecord if0 (test expr) (pass expr) (fail expr))
(defrecord with (var symbol) (term expr) (body expr))
...

and

(ematch expr   ;; this expands to typecase
  (number ...) ;; number is not a record this clause is
               ;; copied literally
  ..
  (add (l r) ...) ;; add is a record and is expanded
                  ;; and l r are bounded to
                  ;; (add-lhs expr) (add-rhs expr)


I'll give the whole source of an interpeter written using this
technique, with the old code commented out.
However I lost the interest in this topic somehow I'll answer your
questions if you have some

--8<-------------8<--
;;;; -*- Mode: LISP; Syntax: ANSI-COMMON-LISP; -*-
;;;;

(defpackage "REC.."
  (:use "CL"))

(in-package "REC..")

;; A wrapper around ``defstruct''
(defmacro defrecord (name &body entries)
  (assert (symbolp name))
  (setf (get name :names) (mapcar #'first entries)
	(get name :recordp) t)
  `(defstruct (,name (:constructor ,name ,(mapcar #'first entries)))
    ,@ (mapcar (lambda (entry)
		 `(,(first entry) nil :type ,(second entry)))
	entries)))
;; with-record, handier access to record fields

(defun recordp (type)
  (get type :recordp))

;; utility functions
;; make-accessor : symbol symbol -> symbol
(defun make-accessor (name field)
  (intern (concatenate 'string (symbol-name name) "-" (symbol-name
field))))
;; make-accessor-expansion : symbol symbol symbol -> form
(defun make-accessor-expansion (name field record)
  `(,(make-accessor name field) ,record))

(defmacro with-record ((inst type) &body body)
  `(symbol-macrolet
    ,(mapcar (lambda (name)
	       (list name (make-accessor-expansion type name inst)))
	     (get type :names))
    ,@body))

(defun make-etypecase-clause (inst type aliases body)
  `(,type (with-record/for-match (,inst ,type) ,aliases
				 ,@body)))

(defmacro with-record/for-match ((inst type) aliases &body body)
  `(symbol-macrolet
    ,(mapcar (lambda (name alias)
	       (list alias (make-accessor-expansion type name inst)))
	     (get type :names)
	     aliases)
    ,@body))


(defmacro ematch (inst &rest clauses)
  `(etypecase ,inst
    ,@ (mapcar (lambda (clause)
		 (if (recordp (first clause))
		     (make-etypecase-clause inst
					    (first clause) ; type
					    (second clause) ; aliases
					    (rest (rest clause))) ; body
		     clause))
    clauses)))

;; The EXPR type
(deftype expr ()
  `(or number symbol add sub mul div if0 with rec fun app))

;; Records which are subtypes of EXPR
(defrecord add (lhs expr) (rhs expr))
(defrecord sub (lhs expr) (rhs expr))
(defrecord mul (lhs expr) (rhs expr))
(defrecord div (lhs expr) (rhs expr))
(defrecord if0 (test expr) (pass expr) (fail expr))
(defrecord with (var symbol) (term expr) (body expr))
(defrecord fun (param symbol) (body expr))
(defrecord rec (name symbol) (proc fun) (body expr))
(defrecord app (fun expr) (arg expr))


;; (defstruct add
;;   (lhs nil :type expr)
;;   (rhs nil :type expr))
;; (defstruct sub
;;   (lhs nil :type expr)
;;   (rhs nil :type expr))
;; (defstruct mul
;;   (lhs nil :type expr)
;;   (rhs nil :type expr))
;; (defstruct div
;;   (lhs nil :type expr)
;;   (rhs nil :type expr))
;; (defstruct with
;;   (var nil :type symbol)
;;   (term nil :type expr)
;;   (body nil :type expr))
;; ;; added
;; (defstruct fun
;;   (param nil :type symbol)
;;   (body nil :type expr))
;; (defstruct rec
;;   (name nil :type symbol)
;;   (proc nil :type fun)			; type fun, NOT! expr
;;   (body nil :type expr))
;; (defstruct app
;;   (fun nil :type expr)
;;   (arg nil :type expr))
;; (defstruct if0
;;   (test nil :type expr)
;;   (consequent nil :type expr)
;;   (alternative nil :type expr))

;; ;; Final defintion of expr


;; ;; Utility constructors
;; (defun add (lhs rhs)
;;   (make-add :lhs lhs :rhs rhs))
;; (defun sub (lhs rhs)
;;   (make-sub :lhs lhs :rhs rhs))
;; (defun mul (lhs rhs)
;;   (make-mul :lhs lhs :rhs rhs))
;; (defun div (lhs rhs)
;;   (make-div :lhs lhs :rhs rhs))
;; (defun with (var term body)
;;   (make-with :var var :term term :body body))
;; (defun fun (param body)
;;   (make-fun :param param :body body))
;; (defun rec (name proc body)
;;   (make-rec :name name :proc proc :body body))
;; (defun app (fun arg)
;;   (make-app :fun fun :arg arg))
;; (defun if0 (test consequent alternative)
;;   (make-if0 :test test :consequent consequent :alternative
alternative))


;; The BNF of <rcfae> language
#|
<fwae>  ::= <num>
          | (+ <rcfae> <rcfae>)
          | (- <rcfae> <rcfae>)
          | (* <rcfae> <rcfae>)
          | (/ <rcfae> <rcfae>)
          | <id>
          | (with (<id> <rcfae>) <rcfae>)
          | (rec (<id> <rcfae>) <rcfae>)
          | (fun (<id>) <rcfae>)
          | (if0 <rcfae> <rcfae> <rcfae>)
          | (<rcfae> <cfae>)
|#

;; parse : sexp -> expr
(defun parse (sexp)
  (cond ((numberp sexp) sexp)
	((symbolp sexp) sexp)
	(t (case (first sexp)
		 ((+) (add (parse (second sexp))
			   (parse (third sexp))))
		 ((-) (sub (parse (second sexp))
			   (parse (third sexp))))
		 ((*) (mul (parse (second sexp))
			   (parse (third sexp))))
		 ((/) (div (parse (second sexp))
			   (parse (third sexp))))
		 ((with) (with (first (second sexp))
			       (parse (second (second sexp)))
			       (parse (third sexp))))
		 ((rec) (rec (first (second sexp))
			     (parse (second (second sexp)))
			     (parse (third sexp))))
		 ((fun) (fun (first (second sexp))
			     (parse (third sexp))))
		 ((if0) (if0 (parse (second sexp))
			     (parse (third sexp))
			     (parse (fourth sexp))))
		 (otherwise (app (parse (first sexp))
				 (parse (second sexp))))))))

;;;; The VALUE type
(deftype value ()
  '(or number closure recursive-closure))

;;;; The ENV type
(deftype env ()
  '(or null entry))

;; completing the definition of VALUE and ENV
(defrecord closure (param symbol) (body expr) (env env))
(defrecord recursive-closure
    (name symbol) (param symbol) (body expr) (env env))

(defrecord entry (var symbol) (value value) (env env))

;; (defstruct closure
;;   (param nil :type symbol)
;;   (body nil :type expr)
;;   (env nil :type env))

;; (defstruct recursive-closure
;;   (name nil :type symbol)
;;   (param nil :type symbol)
;;   (body nil :type expr)
;;   (env nil :type env))

;; (defstruct entry
;;   (var nil :type symbol)
;;   (value nil :type value)
;;   (env nil :type env))

;; ;; Utility Constructors
;; (defun closure (param body env)
;;   (make-closure :param param :body body :env env))

;; (defun recursive-closure (name param body env)
;;   (make-recursive-closure :name name :param param :body body :env
env))

;; (defun entry (var value env)
;;   (make-entry :var var :value value :env env))

;; lookup : symbol env -> closure
#+nil
(defun lookup (name env)
  (etypecase env
    (null (error "Identifier not bound - LOOKUP: ~A~%" name))
    (entry (cond ((eq (entry-var env) name) (entry-value env))
		 (t (lookup name (entry-env env)))))))

;; lookup : symbol env -> value
(defun lookup (name env)
  (ematch env
    (null (error "Identifier not bound - LOOKUP: ~A~%" name))
    (entry (var value env0)
	   (cond ((eq var name) value)
		 (t (lookup name env0))))))

;; interpr : expr -> value
#+nil
(defun interp (expr env)
  (etypecase expr
    (number expr)
    (symbol (lookup expr env))
    (add (+ (interp (add-lhs expr) env)
	    (interp (add-rhs expr) env)))
    (sub (- (interp (sub-lhs expr) env)
	    (interp (sub-rhs expr) env)))
    (mul (* (interp (mul-lhs expr) env)
	    (interp (mul-rhs expr) env)))
    (div (/ (interp (div-lhs expr) env)
	    (interp (div-rhs expr) env)))
    (with (interp (with-body expr)
		  (entry (with-var expr)
			 (interp (with-term expr) env)
			 env)))
    (fun (closure (fun-param expr) (fun-body expr) env))
    (rec (interp (rec-body expr)
		 (entry (rec-name expr)
			(recursive-closure
			 (rec-name expr)
			 (fun-param (rec-proc expr))
			 (fun-body (rec-proc expr))
			 env)
			env)))

    (if0 (if (zerop (interp (if0-test expr) env))
	     (interp (if0-consequent expr) env)
	     (interp (if0-alternative expr) env)))
    (app (let ((closure (interp (app-fun expr) env))
	       (value (interp (app-arg expr) env)))
	   (etypecase closure
	     (closure
	      (interp (closure-body closure)
		      (entry (closure-param closure)
			     value
			     (closure-env closure))))
	     (recursive-closure
	      (interp (recursive-closure-body closure)
		      (entry (recursive-closure-name closure)
			     closure
			     (entry (recursive-closure-param closure)
				     value
				     env)))))))))
;; interp : expr -> value
(defun interp (expr env)
  (ematch expr
    (number expr)
    (symbol (lookup expr env))
    (add (l r)
	 (+ (interp l env) (interp r env)))
    (sub (l r)
	 (- (interp l env) (interp r env)))
    (mul (l r)
	 (* (interp l env) (interp r env)))
    (div (l r)
	 (/ (interp l env) (interp r env)))
    (with (var term body)
	  (interp body (entry var (interp term env) env)))
    (fun (param body)
	 (closure param body env))
    (rec (name proc body)
	 (interp body
		 (entry name
			(recursive-closure name
					   (fun-param proc)
					   (fun-body proc)
					   env)
			env)))
    (if0 (test pass fail)
	 (if (zerop (interp test env))
	     (interp pass env)
	     (interp fail env)))
    (app (fun arg)
	 (let ((closure (interp fun env))
	       (value (interp arg env)))
	   (with-record (closure closure)
	     (interp body
		     (entry param value env)))))))


;; sexp->value : sexp -> value
(defun sexp->value (sexp)
  (interp (parse sexp) nil))

--8<-------------8<--
From: lin8080
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <42A36606.846B1C37@freenet.de>
O-MY-GLIFE schrieb:

> ;; parse : sexp -> expr
> (defun parse (sexp)
>   (cond ((numberp sexp) sexp)
>         ((symbolp sexp) sexp)

>         (t (case (first sexp)
>                  ((+) (add (parse (second sexp))
>                   ....
>                  (otherwise (app (parse (first sexp))


Hei. A case-list inside a cond. Never saw this construct. Did that work
well? What about time?

stefan
From: O-MY-GLIFE
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <1118008502.468542.83750@g49g2000cwa.googlegroups.com>
lin8080 wrote:
> O-MY-GLIFE schrieb:
>
> > ;; parse : sexp -> expr
> > (defun parse (sexp)
> >   (cond ((numberp sexp) sexp)
> >         ((symbolp sexp) sexp)
>
> >         (t (case (first sexp)
> >                  ((+) (add (parse (second sexp))
> >                   ....
> >                  (otherwise (app (parse (first sexp))
>
>
> Hei. A case-list inside a cond. Never saw this construct. Did that work
> well? What about time?
>
> stefan

Let see:

* (macroexpand-1 '(case x (1 'foo) (2 'bar)))

(LET ((#:G4299 X))
  (DECLARE (IGNORABLE #:G4299))
  (COND ((EQL #:G4299 '1) NIL 'FOO) ((EQL #:G4299 '2) NIL 'BAR)))
T

To make a long story short case expands to cond and cond expands (at
least in some implementations) to nested ifs.

So finally, all we have is a a lot of nested ifs. With the usual
performance, I guess.

P.S. BTW, the code for evaluating the recursive functions in the
"modern" version of interp is wrong. Another ematch/typecase is needed
to distinguish between closure and recursive-closure.
From: Jens Axel Søgaard
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <42a1b323$0$232$edfadb0f@dread12.news.tele.dk>
HB wrote:

> Does anyone know if someone already
> implemented something like define-datatype? Or has CL something similar
> and I'm just too stupid to find it in the docs?

The original Scheme code can be found here:

   <http://www.cs.indiana.edu/eopl/code/interps/define-datatype.scm>

-- 
Jens Axel Søgaard
From: Pascal Bourguignon
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <87fyvy86p3.fsf@thalassa.informatimago.com>
"HB" <·······@gmail.com> writes:
> I started reading "Essentials of Programming Languages" by Friedman,
> Wand and Haynes. I wanted to implement the examples and the source of
> the book in in CL, mainly because I like the
> Emacs-Slime-SBCL-Combination. For SICP that was no big problem. Problem
> in this case is, the book extensively uses a define-datatype macro
> (which is actually quite cool) that is defined using syntax-case.
> Porting define-datatype in a reasonable amount of time unfortunately is
> way beyond my capabilities. Does anyone know if someone already
> implemented something like define-datatype? Or has CL something similar
> and I'm just too stupid to find it in the docs?

You don't need to translate it.  As often is the case, when you
translate 1000 LOC of a random language, you end  with between only 10
and 100 of Common Lisp LOC.

Here you have 736 useless lines: use deftype and defstruct instead. 

For example, you can write this:

(define-datatype define-datatype:test:btree define-datatype:test:btree?
  (define-datatype:test:empty-btree)
  (define-datatype:test:btree-node
    (left define-datatype:test:btree?)
    (key integer?)
    (right define-datatype:test:btree?)))


as:

(deftype btree () '(or null btree-node))
(defstruct btree-node
   (left  nil :type btree*)
   (key  0    :type integer)
   (right nil :type btree*))
(defun empty-btree () nil) ; Is this really useful? Use NIL for all your empty stuff!


(typep (make-btree-node) 'btree)  --> T
(typep nil               'btree)  --> T
(typep 42                'btree)  --> NIL


-- 
__Pascal Bourguignon__                     http://www.informatimago.com/

This is a signature virus.  Add me to your signature and help me to live
From: HB
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <1117989553.605571.106000@g47g2000cwa.googlegroups.com>
Hei

@Jens: Yeah, I already found the scheme sources, that's the way I knew
I couldn't reimplement it on the fly. I meant an implementation in
Common Lisp, should've said that explicit.

@Pascal: Works without problem for a normal recursive definition like
binary tree, you're right there. Trying some of the more advanced
examples get's ugly fast AFAICS.

@O-MY-GLIFE: yeah, that's what I was looking for.

@EVERYBODY: Thanks for your answers, I appreciate it.

Greertings HB
From: Jens Axel Søgaard
Subject: Re: essentials of programming languages in common lisp
Date: 
Message-ID: <42a33521$0$214$edfadb0f@dread12.news.tele.dk>
HB wrote:
> Hei
> 
> @Jens: Yeah, I already found the scheme sources, that's the way I knew
> I couldn't reimplement it on the fly. I meant an implementation in
> Common Lisp, should've said that explicit.

You were explicit. The code weren't meant for you, but for
that CL'er that could either port it or point to a similar
construct, but didn't know EOPL.

-- 
Jens Axel Søgaard
comp.lang.lisp / 2005 / jun