From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.devel Subject: some notes from after the recent elisp SoC Date: Thu, 10 Feb 2011 18:38:55 +0100 Message-ID: NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1297359285 10160 80.91.229.12 (10 Feb 2011 17:34:45 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Thu, 10 Feb 2011 17:34:45 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Thu Feb 10 18:34:40 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1PnaPE-0003SP-Dp for guile-devel@m.gmane.org; Thu, 10 Feb 2011 18:34:39 +0100 Original-Received: from localhost ([127.0.0.1]:54765 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PnaPC-0004hl-FA for guile-devel@m.gmane.org; Thu, 10 Feb 2011 12:34:10 -0500 Original-Received: from [140.186.70.92] (port=36688 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PnaOv-0004eB-5P for guile-devel@gnu.org; Thu, 10 Feb 2011 12:33:56 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PnaOr-0003Oe-Lw for guile-devel@gnu.org; Thu, 10 Feb 2011 12:33:52 -0500 Original-Received: from a-pb-sasl-sd.pobox.com ([64.74.157.62]:47730 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PnaOr-0003OR-Bw for guile-devel@gnu.org; Thu, 10 Feb 2011 12:33:49 -0500 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-sd.pobox.com (Postfix) with ESMTP id 0FDCF4ACC for ; Thu, 10 Feb 2011 12:34:49 -0500 (EST) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to :subject:date:message-id:mime-version:content-type; s=sasl; bh=y P8U67+Fe/XApOopb01Qmk+y/co=; b=HwieQb/HM0dO5BBN2yJgG83gQ4VvipaCG //P2oVrRmXHvg/MEVjP5hCQ8LdKzJinW1Gh+VOcLWvr6rvVFljvuZXiUgXR9Vx3J 4Yz3umhDYuPPwxxEwkJ1lF7EJwR/+cSV/dF1DFxvdDsBa0cve7513deYvnc6b9tV UC2M0bWROo= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:subject :date:message-id:mime-version:content-type; q=dns; s=sasl; b=Pmq 0C+p7kYMQLElya0qcRDp/SyHUZpff8kRObWYqFcuHfMYR7hmVWiT9gvzf1cTVPv4 1u2P7OK7htWuOpUFaIBBXSW52saz6tzMeMqoNV+92P5DdF0Sr5lZG6aTE/VOdq/+ Q3+iSudQ1yA78icaXVhHfvivh69XmMoD/VrD9NDo= Original-Received: from a-pb-sasl-sd.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-sd.pobox.com (Postfix) with ESMTP id 0BD6A4ACB for ; Thu, 10 Feb 2011 12:34:49 -0500 (EST) Original-Received: from unquote.localdomain (unknown [90.164.198.39]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-sd.pobox.com (Postfix) with ESMTPSA id ACE384ACA for ; Thu, 10 Feb 2011 12:34:47 -0500 (EST) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) X-Pobox-Relay-ID: 0F2DF8FE-353C-11E0-8DD6-F13235C70CBC-02397024!a-pb-sasl-sd.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 (beta) X-Received-From: 64.74.157.62 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:11546 Archived-At: --=-=-= 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: --=-=-= Content-Disposition: attachment; filename=gabriel.el ;;; 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 (+ . ;;; ), the code stored under the atom '+ with indicator ;;; DERIV will take 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. --=-=-= Content-Disposition: attachment; filename=bench2.el (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 ())))))))) --=-=-= Content-Disposition: attachment; filename=bench2.scm (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))))) --=-=-= Content-Disposition: attachment; filename=boot.el (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))) --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=bigsym.diff Content-Description: attachment commit 217cc7db1fc049865c3ec32257975c9f7a7ed4dd Author: Brian Templeton 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); } 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) @@ -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); --=-=-= Regards, Andy -- http://wingolog.org/ --=-=-=--