From: Andy Wingo <wingo@pobox.com>
To: guile-devel <guile-devel@gnu.org>
Subject: some notes from after the recent elisp SoC
Date: Thu, 10 Feb 2011 18:38:55 +0100 [thread overview]
Message-ID: <m31v3fdc28.fsf@unquote.localdomain> (raw)
[-- Attachment #1: Type: text/plain, Size: 1855 bytes --]
Hi,
Here are some notes that Brian Templeton had sent me at the end of the
recent SoC that didn't make it to the list, for posterity.
recent changes pushed:
* Unbound fluids should be ready for inclusion in Guile (I also added
`variable-unset!' for "undefining" variables)
* Function bindings are no longer special; this increases TAK
performance somewhat, and shouldn't introduce serious compatibility
problems (cl.el `flet' is only used ~30 times in Emacs's packages, and
some of those uses would work just as well with lexical `flet')
* I ported the rest of the Gabriel benchmarks to Elisp (only minor
changes required for thirty-year-old code -- Lisp is quite a stable
language family!); I'm not sure what the copyright/license status of
the orginial code is, so it may not be able to go into Guile but is
useful nonetheless. Gabriel benchmarks attached, along with bench2.el
and bench2.scm. Use bench2.el by evaluating (in *scratch*)
(bpt-repeat X (bpt-time* Y (lambda () BENCHMARK))),
where X and Y are integers, and BENCHMARK runs the benchmark once
(e.g. "(tak 18 12 6)"). Use bench2.scm by evaluating
(repeat X (time Y BENCHMARK))
Elisp functions are in `(language elisp runtime function-slot)', and
are stored directly in the module rather than in fluids after the
lexical function bindings change.
* More Elisp subrs added, mostly wrapping guile procedures; there aren't
really many nontrivial subrs or special forms left that make sense
without Emacs integration. "boot.el" is attached.
* Trivial compatibility fixes. Also, initial attempt at "wide symbols"
patch attached -- it only adds slots to variable objects, and doesn't
have VM or Elisp compiler integration.
All if this was merged in. The files he attached were as follows:
[-- Attachment #2: gabriel.el --]
[-- Type: text/plain, Size: 33519 bytes --]
;;; TAK
(defun tak (x y z)
(if (not (< y x))
z
(tak (tak (1- x) y z)
(tak (1- y) z x)
(tak (1- z) x y))))
;;; STAK
(defvar x)
(defvar y)
(defvar z)
(defun stak (x y z)
(stak-aux))
(defun stak-aux ()
(if (not (< y x))
z
(let ((x (let ((x (1- x))
(y y)
(z z))
(stak-aux)))
(y (let ((x (1- y))
(y z)
(z x))
(stak-aux)))
(z (let ((x (1- z))
(y x)
(z y))
(stak-aux))))
(stak-aux))))
;;; CTAK
(defun ctak (x y z)
(catch 'ctak (ctak-aux x y z)))
(defun ctak-aux (x y z)
(cond ((not (< y x))
(throw 'ctak z))
(t (ctak-aux
(catch 'ctak
(ctak-aux (1- x)
y
z))
(catch 'ctak
(ctak-aux (1- y)
z
x))
(catch 'ctak
(ctak-aux (1- z)
x
y))))))
;;; TAKL
(defun listn (n)
(if (not (= 0 n))
(cons n (listn (1- n)))))
(defvar 18l (listn 18))
(defvar 12l (listn 12))
(defvar 6l (listn 6))
(defun mas (x y z)
(if (not (shorterp y x))
z
(mas (mas (cdr x)
y z)
(mas (cdr y)
z x)
(mas (cdr z)
x y))))
(defun shorterp (x y)
(and y (or (null x)
(shorterp (cdr x)
(cdr y)))))
;;; BOYER
(defvar unify-subst)
(defvar temp-temp)
(defun add-lemma (term)
(cond ((and (not (atom term))
(eq (car term)
(quote equal))
(not (atom (cadr term))))
(setf (get (car (cadr term)) (quote lemmas))
(cons term (get (car (cadr term))
(quote lemmas)))))
(t (error "~%ADD-LEMMA did not like term: ~a" term))))
(defun add-lemma-lst (lst)
(cond ((null lst)
t)
(t (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(defun apply-subst (alist term)
(cond ((atom term)
(cond ((setq temp-temp (assq term alist))
(cdr temp-temp))
(t term)))
(t (cons (car term)
(apply-subst-lst alist (cdr term))))))
(defun apply-subst-lst (alist lst)
(cond ((null lst)
nil)
(t (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(defun falsep (x lst)
(or (equal x (quote (f)))
(member x lst)))
(defun one-way-unify (term1 term2)
(progn (setq unify-subst nil)
(one-way-unify1 term1 term2)))
(defun one-way-unify1 (term1 term2)
(cond ((atom term2)
(cond ((setq temp-temp (assq term2 unify-subst))
(equal term1 (cdr temp-temp)))
(t (setq unify-subst (cons (cons term2 term1)
unify-subst))
t)))
((atom term1)
nil)
((eq (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(t nil)))
(defun one-way-unify1-lst (lst1 lst2)
(cond ((null lst1)
t)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(t nil)))
(defun rewrite (term)
(cond ((atom term)
term)
(t (rewrite-with-lemmas
(cons (car term)
(rewrite-args (cdr term)))
(get (car term)
(quote lemmas))))))
(defun rewrite-args (lst)
(cond ((null lst)
nil)
(t (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(defun rewrite-with-lemmas (term lst)
(cond ((null lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite
(apply-subst unify-subst (caddr (car lst)))))
(t (rewrite-with-lemmas term (cdr lst)))))
(defun setup ()
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (1- x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (1- x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))
(f)))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqpr x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (1- a)
(zero))
(equal (1- b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length
(cons
x1
(cons
x2
(cons
x3
(cons
x4
(cons
x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal t z)
(equal f z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(defun tautologyp (x true-lst false-lst)
(cond ((truep x true-lst)
t)
((falsep x false-lst)
nil)
((atom x)
nil)
((eq (car x)
(quote if))
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(t (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(t nil)))
(defun tautp (x)
(tautologyp (rewrite x)
nil nil))
(defun test ()
(let (ans term)
(setq term
(apply-subst
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b)))))
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))))
(setq ans (tautp term))))
(defun trans-of-implies (n)
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n)))
(defun trans-of-implies1 (n)
(cond ((eql n 1)
(list (quote implies)
0 1))
(t (list (quote and)
(list (quote implies)
(1- n)
n)
(trans-of-implies1 (1- n))))))
(defun truep (x lst)
(or (equal x (quote (t)))
(member x lst)))
(eval-when (compile load eval)
(setup))
;;; make sure you've run (setup) then call: (test)
;;; BROWSE
;;; BROWSE -- Benchmark to create and browse through
;;; an AI-like data base of units.
;;; n is # of symbols
;;; m is maximum amount of stuff on the plist
;;; npats is the number of basic patterns on the unit
;;; ipats is the instantiated copies of the patterns
(defvar rand 21)
(defmacro char1 (x) `(aref (symbol-name ,x) 0))
(defun init (n m npats ipats)
(let ((ipats (copy-tree ipats)))
(do ((p ipats (cdr p)))
((null (cdr p)) (rplacd p ipats)))
(do ((n n (1- n))
(i m (cond ((= i 0) m)
(t (1- i))))
(name (gensym) (gensym))
(a ()))
((= n 0) a)
(push name a)
(do ((i i (1- i)))
((= i 0))
(setf (get name (gensym)) nil))
(setf (get name 'pattern)
(do ((i npats (1- i))
(ipats ipats (cdr ipats))
(a ()))
((= i 0) a)
(push (car ipats) a)))
(do ((j (- m i) (1- j)))
((= j 0))
(setf (get name (gensym)) nil)))))
(defun browse-random ()
(setq rand (mod (* rand 17) 251)))
(defun randomize (l)
(do ((a ()))
((null l) a)
(let ((n (mod (browse-random) (length l))))
(cond ((= n 0)
(push (car l) a)
(setq l (cdr l)))
(t
(do ((n n (1- n))
(x l (cdr x)))
((= n 1)
(push (cadr x) a)
(rplacd x (cddr x)))))))))
(defun match (pat dat alist)
(cond ((null pat)
(null dat))
((null dat) ())
((or (eq (car pat) '\?)
(eq (car pat)
(car dat)))
(match (cdr pat) (cdr dat) alist))
((eq (car pat) '*)
(or (match (cdr pat) dat alist)
(match (cdr pat) (cdr dat) alist)
(match pat (cdr dat) alist)))
(t (cond
((atom (car pat))
(cond
((eq (char1 (car pat)) ??)
(let ((val (assoc (car pat) alist)))
(cond (val (match
(cons (cdr val)
(cdr pat))
dat
alist))
(t (match
(cdr pat)
(cdr dat)
(cons (cons (car pat)
(car dat))
alist))))))
((eq (char1 (car pat)) ?*)
(let ((val (assoc (car pat) alist)))
(cond (val (match
(append (cdr val)
(cdr pat))
dat
alist))
(t
(do ((l () (nconc l (cons (car d) nil)))
(e (cons () dat) (cdr e))
(d dat (cdr d)))
((null e) ())
(cond ((match
(cdr pat)
d
(cons (cons (car pat) l)
alist))
(return t))))))))))
(t (and
(not (atom (car dat)))
(match (car pat)
(car dat) alist)
(match (cdr pat)
(cdr dat) alist)))))))
(defun browse ()
(investigate (randomize
(init
100
10
4
'((a a a b b b b a a a a a b b a a a)
(a a b b b b a a
(a a)(b b))
(a a a b (b a) b a b a))))
'((*a \?b *b \?b a *a a *b *a)
(*a *b *b *a (*a) (*b))
(\? \? * (b a) * \? \?))))
(defun investigate (units pats)
(do ((units units (cdr units)))
((null units))
(do ((pats pats (cdr pats)))
((null pats))
(do ((p (get (car units) 'pattern)
(cdr p)))
((null p))
(match (car pats) (car p) ())))))
;;; call: (browse)
;;; DESTRUCTIVE
;;; DESTRU -- Destructive operation benchmark
(defun destructive (n m)
(let ((l (do ((i 10 (1- i))
(a () (push () a)))
((= i 0) a))))
(do ((i n (1- i)))
((= i 0))
(cond ((null (car l))
(do ((l l (cdr l)))
((null l))
(or (car l)
(rplaca l (cons () ())))
(nconc (car l)
(do ((j m (1- j))
(a () (push () a)))
((= j 0) a)))))
(t
(do ((l1 l (cdr l1))
(l2 (cdr l) (cdr l2)))
((null l2))
(rplacd (do ((j (floor (length (car l2)) 2)
(1- j))
(a (car l2) (cdr a)))
((zerop j) a)
(rplaca a i))
(let ((n (floor (length (car l1)) 2)))
(cond ((= n 0) (rplaca l1 ())
(car l1))
(t
(do ((j n (1- j))
(a (car l1) (cdr a)))
((= j 1)
(prog1 (cdr a)
(rplacd a ())))
(rplaca a i))))))))))))
;;; call: (destructive 600. 50.)
;;; TRAVERSE
;;; TRAVERSE -- Benchmark that creates and traverses
;;; a tree structure.
(defstruct node
(parents ())
(sons ())
(sn (snb))
(entry1 ())
(entry2 ())
(entry3 ())
(entry4 ())
(entry5 ())
(entry6 ())
(mark ()))
(defvar *sn* 0)
(defvar *rand* 21)
(defvar *count* 0)
(defvar *marker* nil)
(defvar *root*)
(defun snb ()
(setq *sn* (1+ *sn*)))
(defun seed ()
(setq *rand* 21))
(defun traverse-random () (setq *rand* (mod (* *rand* 17)
251)))
(defun traverse-remove (n q)
(cond ((eq (cdr (car q)) (car q))
(prog2 () (caar q) (rplaca q ())))
((= n 0)
(prog2 () (caar q)
(do ((p (car q) (cdr p)))
((eq (cdr p) (car q))
(rplaca q
(rplacd p (cdr (car q))))))))
(t (do ((n n (1- n))
(q (car q) (cdr q))
(p (cdr (car q)) (cdr p)))
((= n 0) (prog2 () (car q) (rplacd q p)))))))
(defun traverse-select (n q)
(do ((n n (1- n))
(q (car q) (cdr q)))
((= n 0) (car q))))
(defun add (a q)
(cond ((null q)
`(,(let ((x `(,a)))
(rplacd x x) x)))
((null (car q))
(let ((x `(,a)))
(rplacd x x)
(rplaca q x)))
(t (rplaca q
(rplacd (car q) `(,a . ,(cdr (car q))))))))
(defun create-structure (n)
(let ((a `(,(make-node))))
(do ((m (1- n) (1- m))
(p a))
((= m 0) (setq a `(,(rplacd p a)))
(do ((unused a)
(used (add (traverse-remove 0 a) ()))
(x) (y))
((null (car unused))
(find-root (traverse-select 0 used) n))
(setq x (traverse-remove
(mod (traverse-random) n)
unused))
(setq y (traverse-select
(mod (traverse-random) n)
used))
(add x used)
(setf (node-sons y) `(,x . ,(node-sons y)))
(setf (node-parents x) `(,y . ,(node-parents x))) ))
(push (make-node) a))))
(defun find-root (node n)
(do ((n n (1- n)))
((= n 0) node)
(cond ((null (node-parents node))
(return node))
(t (setq node (car (node-parents node)))))))
(defun travers (node mark)
(cond ((eq (node-mark node) mark) ())
(t (setf (node-mark node) mark)
(setq *count* (1+ *count*))
(setf (node-entry1 node) (not (node-entry1 node)))
(setf (node-entry2 node) (not (node-entry2 node)))
(setf (node-entry3 node) (not (node-entry3 node)))
(setf (node-entry4 node) (not (node-entry4 node)))
(setf (node-entry5 node) (not (node-entry5 node)))
(setf (node-entry6 node) (not (node-entry6 node)))
(do ((sons (node-sons node) (cdr sons)))
((null sons) ())
(travers (car sons) mark)))))
(defun traverse (root)
(let ((*count* 0))
(travers root (setq *marker* (not *marker*)))
*count*))
(defmacro init-traverse ()
(prog2 (setq *root* (create-structure 100)) ()))
(defmacro run-traverse ()
(do ((i 50 (1- i)))
((= i 0))
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)))
;;; to initialize, call: (init-traverse)
;;; to run traverse, call: (run-traverse)
;;; N.B. max-lisp-eval-depth needs to be 1000 or so
;;; DERIV
;;; DERIV -- This is the Common Lisp version of a symbolic
;;; derivative benchmark written by Vaughan Pratt.
;;; It uses a simple subset of Lisp and does a lot of
;;; CONSing.
(defun deriv-aux (a) (list '/ (deriv a) a))
(defun deriv (a)
(cond
((atom a)
(cond ((eq a 'x) 1) (t 0)))
((eq (car a) '+)
(cons '+ (mapcar #'deriv (cdr a))))
((eq (car a) '-)
(cons '- (mapcar #'deriv
(cdr a))))
((eq (car a) '*)
(list '*
a
(cons '+ (mapcar #'deriv-aux (cdr a)))))
((eq (car a) '/)
(list '-
(list '/
(deriv (cadr a))
(caddr a))
(list '/
(cadr a)
(list '*
(caddr a)
(caddr a)
(deriv (caddr a))))))
(t 'error)))
(defun run ()
(declare (fixnum i)) ;improves the code a little
(do ((i 0 (1+ i)))
((= i 1000)) ;runs it 5000 times
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
;;; call: (run)
;;; DDERIV
;;; DDERIV -- The Common Lisp version of a
;;; symbolic derivative benchmark, written by Vaughan Pratt.
;;;
;;; This benchmark is a variant of the simple symbolic
;;; derivative program (DERIV). The main change is that it is
;;; `table-driven.' Instead of using a large COND that branches
;;; on the CAR of the expression, this program finds the code
;;; that will take the derivative on the property list of the
;;; atom in the CAR position. So, when the expression is (+ .
;;; <rest>), the code stored under the atom '+ with indicator
;;; DERIV will take <rest> and return the derivative for '+. The
;;; way that MacLisp does this is with the special form: (DEFUN
;;; (FOO BAR) ...). This is exactly like DEFUN with an atomic
;;; name in that it expects an argument list and the compiler
;;; compiles code, but the name of the function with that code
;;; is stored on the property list of FOO under the indicator
;;; BAR, in this case.
(defun dderiv-aux (a)
(list '/ (dderiv a) a))
(defun +dderiv (a)
(cons '+ (mapcar 'dderiv a)))
(defun -dderiv (a)
(cons '- (mapcar 'dderiv a)))
(defun *dderiv (a)
(list '* (cons '* a)
(cons '+ (mapcar 'dderiv-aux a))))
(defun /dderiv (a)
(list '-
(list '/
(dderiv (car a))
(cadr a))
(list '/
(car a)
(list '*
(cadr a)
(cadr a)
(dderiv (cadr a))))))
(mapc
#'(lambda (x)
(setf
(get (car x) 'dderiv)
(symbol-function (cadr x))))
'((+ +dderiv)(- -dderiv)(* *dderiv)(/ /dderiv)))
(defun dderiv (a)
(cond
((atom a)
(cond ((eq a 'x) 1) (t 0)))
(t (let ((dderiv (get (car a) 'dderiv)))
(cond (dderiv (funcall dderiv (cdr a)))
(t 'error))))))
(defun run ()
(declare (fixnum i))
(do ((i 0 (1+ i)))
((= i 1000))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
;;; call: (run)
;;; DIV2
;;; DIV2 -- Benchmark that divides by 2 using lists of n NIL's.
;;; This file contains a recursive as well as an iterative test.
(defun create-n (n)
(do ((n n (1- n))
(a () (push () a)))
((= n 0) a)))
(defvar ll (create-n 200))
(defun iterative-div2 (l)
(do ((l l (cddr l))
(a () (push (car l) a)))
((null l) a)))
(defun recursive-div2 (l)
(cond ((null l) ())
(t (cons (car l) (recursive-div2 (cddr l))))))
(defun test-1 (l)
(do ((i 300 (1- i)))
((= i 0))
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)))
(defun test-2 (l)
(do ((i 300 (1- i)))
((= i 0))
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)))
;;; for the iterative test call: (test-1 ll)
;;; for the recursive test call: (test-2 ll)
;;; FFT skipped due to lack of PROG.
;;; PUZZLE, TRIANGLE, FPRINT, FREAD, TPRINT, FRPOLY remain.
[-- Attachment #3: bench2.el --]
[-- Type: text/plain, Size: 684 bytes --]
(defun bpt-repeat* (n thunk)
(while (/= n 0)
(funcall thunk)
(setq n (1- n))))
(defmacro bpt-repeat (n expr)
`(bpt-repeat* ,n (lambda () ,expr)))
(defun bpt-msecs (v)
(let ((low (cadr v))
(microsec (caddr v)))
(+ (* low 1000)
(/ microsec 1000))))
(defun bpt-%time (thunk)
(let ((t1 (get-internal-run-time)))
(funcall thunk)
(let ((t2 (get-internal-run-time)))
(assert (= (car t1) (car t2)))
(- (bpt-msecs t2)
(bpt-msecs t1)))))
(defun bpt-time* (n thunk)
(insert
(format "%d\n"
(- (bpt-%time `(lambda () (bpt-repeat* n ,thunk)))
(bpt-%time '(lambda () (bpt-repeat* n (lambda ()))))))))
[-- Attachment #4: bench2.scm --]
[-- Type: text/plain, Size: 710 bytes --]
(define (msecs v)
(quotient (* v 1000) internal-time-units-per-second))
(define (repeat* n thunk)
(let loop ((n n))
(if (= n 0)
(values)
(begin
(thunk)
(repeat* (- n 1) thunk)))))
(define-syntax repeat
(syntax-rules ()
((_ n expr)
(repeat* n (lambda () expr)))))
(define (%time thunk)
(let ((start (times)))
(let ((v (thunk)))
(let ((end (times)))
(msecs (- (tms:utime end) (tms:utime start)))))))
(define (time* n thunk)
(display
(- (%time (lambda () (repeat* n thunk)))
(%time (lambda () (repeat* n (lambda () #f))))))
(newline))
(define-syntax time
(syntax-rules ()
((_ n expr) (time* n (lambda () expr)))))
[-- Attachment #5: boot.el --]
[-- Type: text/plain, Size: 2828 bytes --]
(defvar system-type 'gnu/linux)
(defun set-advertised-calling-convention (&rest args) nil)
(defun add-hook (&rest args) nil)
(defun re-search-forward (&rest args) nil)
(defun re-search-backward (&rest args) nil)
(defun put (&rest args) nil)
(defun make-sparse-keymap (&rest args) nil)
(defun define-key (&rest args) nil)
(defun make-obsolete-variable (&rest args) nil)
(defun make-obsolete (&rest args) nil)
(defun make-variable-buffer-local (&rest args) nil)
(defun identity (arg)
arg)
(defun delete (elt seq)
((guile-ref (srfi srfi-1) delete!) elt seq))
(defun atom (object)
(not ((guile-ref (guile) pair?) object)))
(defun stringp (object)
((guile-ref (guile) string?) object))
(defun symbolp (object)
((guile-ref (guile) symbol?) object))
(defun make-symbol (name)
((guile-ref (guile) make-symbol) name))
(defun member (elt list)
((guile-ref (guile) member) elt list))
(defun hash-table-p (obj) nil)
(defun purecopy (x) x)
(defun defalias (a b &rest x)
(if (and a b)
(if (fboundp b)
(fset a (symbol-function b)))))
(defun defvaralias (a b &rest x)
(if (and a b)
(if (boundp b)
(set a (symbol-value b)))))
(defmacro declare (&rest x) nil)
(defvar features '())
(defun provide (feature)
(if (not (member feature features))
(setq features (cons feature features))))
(defun featurep (feature)
(member feature features))
(defmacro defsubst (&rest args)
`(defun ,@args))
(defmacro define-obsolete-function-alias (obs new &rest fnord)
`(defalias ,obs ,new))
(defmacro define-obsolete-variable-alias (obs new &rest args)
`(defvaralias ,obs ,new))
(defun default-boundp (symbol) (boundp symbol))
(defalias 'nreverse 'reverse)
(defun aref (array idx)
(if (stringp array)
((guile-ref (guile) string-ref) array idx)
((guile-ref (guile) vector-ref) array idx)))
(defun arrayp (object)
(or (stringp object)
((guile-ref (guile) vector?) object)))
(defun aset (array idx newelt)
(if (stringp object)
((guile-ref (guile) string-set!) array idx newelt)
((guile-ref (guile) vector-set!) array idx newelt)))
(defun sin (arg)
((guile-ref (guile) sin) arg))
(defun cos (arg)
((guile-ref (guile) cos) arg))
(defun tan (arg)
((guile-ref (guile) tan) arg))
(defun asin (arg)
((guile-ref (guile) asin) arg))
(defun acos (arg)
((guile-ref (guile) acos) arg))
(defun atan (arg)
((guile-ref (guile) atan) arg))
(defun logior (&rest nums)
((guile-ref (guile) apply) (guile-ref (guile) logior) nums))
(defun lognot (number)
((guile-ref (guile) lognot) number))
(defun logxor (&rest nums)
((guile-ref (guile) apply) (guile-ref (guile) logxor) nums))
(defun logand (&rest nums)
((guile-ref (guile) apply) (guile-ref (guile) logand) nums))
(defun natnump (object)
(and (integerp object) (>= object 0)))
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: attachment --]
[-- Type: text/x-patch, Size: 5021 bytes --]
commit 217cc7db1fc049865c3ec32257975c9f7a7ed4dd
Author: Brian Templeton <bpt@hcoop.net>
Date: Tue Jul 13 17:13:43 2010 -0400
wip
diff --git a/libguile/variable.c b/libguile/variable.c
index a97444c..6592647 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -40,16 +40,41 @@ scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_puts (" value: ", port);
scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
+ scm_puts (" fvalue: ", port);
+ scm_iprin1 (SCM_VARIABLE_FREF (exp), port, pstate);
+ scm_puts (" pvalue: ", port);
+ scm_iprin1 (SCM_VARIABLE_PREF (exp), port, pstate);
scm_putc('>', port);
}
\f
static SCM
+make_variable_star (SCM init, SCM finit, SCM pinit)
+{
+ return scm_double_cell (scm_tc7_variable,
+ SCM_UNPACK (init),
+ SCM_UNPACK (finit),
+ SCM_UNPACK (pinit));
+}
+
+static SCM
make_variable (SCM init)
{
- return scm_cell (scm_tc7_variable, SCM_UNPACK (init));
+ return make_variable_star (init, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_make_variable_star, "make-variable*", 6, 0, 0,
+ (SCM vinitp, SCM finitp, SCM pinitp,
+ SCM vinit, SCM finit, SCM pinit),
+ "")
+#define FUNC_NAME s_scm_make_variable_star
+{
+ return make_variable_star ((scm_is_true (vinitp) ? vinit : SCM_UNDEFINED),
+ (scm_is_true (finitp) ? finit : SCM_UNDEFINED),
+ (scm_is_true (pinitp) ? pinit : SCM_UNDEFINED));
}
+#undef FUNC_NAME
SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0,
(SCM init),
@@ -111,6 +136,64 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_variable_fref, "variable-fref", 1, 0, 0,
+ (SCM var),
+ "Dereference @var{var} and return its function.\n"
+ "@var{var} must be a variable object; see @code{make-variable}\n"
+ "and @code{make-undefined-variable}.")
+#define FUNC_NAME s_scm_variable_fref
+{
+ SCM val;
+ SCM_VALIDATE_VARIABLE (1, var);
+ val = SCM_VARIABLE_FREF (var);
+ if (val == SCM_UNDEFINED)
+ SCM_MISC_ERROR ("variable is funbound: ~S", scm_list_1 (var));
+ return val;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_variable_fset_x, "variable-fset!", 2, 0, 0,
+ (SCM var, SCM val),
+ "Set the function of the variable @var{var} to @var{val}.\n"
+ "@var{var} must be a variable object, @var{val} can be any\n"
+ "value. Return an unspecified value.")
+#define FUNC_NAME s_scm_variable_fset_x
+{
+ SCM_VALIDATE_VARIABLE (1, var);
+ SCM_VARIABLE_FSET (var, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_variable_pref, "variable-pref", 1, 0, 0,
+ (SCM var),
+ "Dereference @var{var} and return its property object.\n"
+ "@var{var} must be a variable object; see @code{make-variable}\n"
+ "and @code{make-undefined-variable}.")
+#define FUNC_NAME s_scm_variable_pref
+{
+ SCM val;
+ SCM_VALIDATE_VARIABLE (1, var);
+ val = SCM_VARIABLE_PREF (var);
+ if (val == SCM_UNDEFINED)
+ SCM_MISC_ERROR ("variable is punbound: ~S", scm_list_1 (var));
+ return val;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_variable_pset_x, "variable-pset!", 2, 0, 0,
+ (SCM var, SCM val),
+ "Set the property object of the variable @var{var} to @var{val}.\n"
+ "@var{var} must be a variable object, @var{val} can be any\n"
+ "value. Return an unspecified value.")
+#define FUNC_NAME s_scm_variable_pset_x
+{
+ SCM_VALIDATE_VARIABLE (1, var);
+ SCM_VARIABLE_PSET (var, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0,
(SCM var),
"Return @code{#t} iff @var{var} is bound to a value.\n"
diff --git a/libguile/variable.h b/libguile/variable.h
index 8faced4..79de689 100644
--- a/libguile/variable.h
+++ b/libguile/variable.h
@@ -34,6 +34,10 @@
#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1 (V)
#define SCM_VARIABLE_SET(V, X) SCM_SET_CELL_OBJECT_1 (V, X)
#define SCM_VARIABLE_LOC(V) (SCM_CELL_OBJECT_LOC ((V), 1))
+#define SCM_VARIABLE_FREF(V) SCM_CELL_OBJECT_2 (V)
+#define SCM_VARIABLE_FSET(V, X) SCM_SET_CELL_OBJECT_2 (V, X)
+#define SCM_VARIABLE_PREF(V) SCM_CELL_OBJECT_3 (V)
+#define SCM_VARIABLE_PSET(V, X) SCM_SET_CELL_OBJECT_3 (V, X)
\f
@@ -42,6 +46,10 @@ SCM_API SCM scm_make_undefined_variable (void);
SCM_API SCM scm_variable_p (SCM obj);
SCM_API SCM scm_variable_ref (SCM var);
SCM_API SCM scm_variable_set_x (SCM var, SCM val);
+SCM_API SCM scm_variable_fref (SCM var);
+SCM_API SCM scm_variable_fset_x (SCM var, SCM val);
+SCM_API SCM scm_variable_pref (SCM var);
+SCM_API SCM scm_variable_pset_x (SCM var, SCM val);
SCM_API SCM scm_variable_bound_p (SCM var);
SCM_INTERNAL void scm_i_variable_print (SCM var, SCM port, scm_print_state *pstate);
[-- Attachment #7: Type: text/plain, Size: 41 bytes --]
Regards,
Andy
--
http://wingolog.org/
next reply other threads:[~2011-02-10 17:38 UTC|newest]
Thread overview: 2+ messages / expand[flat|nested] mbox.gz Atom feed top
2011-02-10 17:38 Andy Wingo [this message]
2011-02-12 11:30 ` some notes from after the recent elisp SoC Andy Wingo
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=m31v3fdc28.fsf@unquote.localdomain \
--to=wingo@pobox.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).