├── .gitignore ├── BUGS ├── COPYING ├── HACKING ├── HOWTO ├── INSTALL ├── Makefile ├── README ├── README.md ├── contrib ├── closette │ ├── README │ ├── closette-tests.lisp │ └── closette.lisp ├── gabriel │ ├── CHANGES │ ├── README │ ├── benchmark.lisp │ ├── boyer.lisp │ ├── browse.lisp │ ├── control.lisp │ ├── ctak.lisp │ ├── dderiv.lisp │ ├── deriv.lisp │ ├── destru-mod.lisp │ ├── destru.lisp │ ├── div2.lisp │ ├── fft-mod.lisp │ ├── fft.lisp │ ├── fprint.lisp │ ├── fread.lisp │ ├── frpoly-mod.lisp │ ├── frpoly.lisp │ ├── integer.lisp │ ├── make-declare.lsp │ ├── puzzle-mod-noproclaim.lisp │ ├── puzzle-mod.lisp │ ├── puzzle-mod1.lisp │ ├── puzzle-mod2.lisp │ ├── puzzle-noproclaim.lisp │ ├── puzzle-sda.lisp │ ├── puzzle.lisp │ ├── stak.lisp │ ├── tak-mod.lisp │ ├── tak.lisp │ ├── takl.lisp │ ├── takr.lisp │ ├── tprint.lisp │ ├── traverse.lisp │ ├── triang-mod.lisp │ ├── triang-old-mod.lisp │ └── triang.lisp └── iclm.el ├── emacs-cl-pkg.el └── src ├── Makefile ├── batch.el ├── cl-arrays.el ├── cl-characters.el ├── cl-compile.el ├── cl-conditions.el ├── cl-conses.el ├── cl-environment.el ├── cl-eval.el ├── cl-evaluation.el ├── cl-filenames.el ├── cl-files.el ├── cl-flow.el ├── cl-format.el ├── cl-hash.el ├── cl-iteration.el ├── cl-loop.el ├── cl-numbers.el ├── cl-objects.el ├── cl-packages.el ├── cl-printer.el ├── cl-reader.el ├── cl-sequences.el ├── cl-streams.el ├── cl-strings.el ├── cl-structures.el ├── cl-subtypep.el ├── cl-symbols.el ├── cl-system.el ├── cl-typep.el ├── cl-types.el ├── emacs-cl ├── func.el ├── interaction.el ├── load-cl.el ├── populate.el ├── tests.el ├── tests.lisp └── utils.el /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.elc 3 | emacs-cl-* 4 | -------------------------------------------------------------------------------- /HACKING: -------------------------------------------------------------------------------- 1 | Random hacking hints: 2 | 3 | To run the tests: 4 | make check 5 | or 6 | (load "tests.lisp") 7 | 8 | Running GCL's ANSI tests: 9 | "rm contrib/gcl-ansi-tests/*.elc" if you have reason to suspect 10 | previously compiled files were generated by a buggy compiler. 11 | 12 | (setq 13 | *default-pathname-defaults* 14 | (pathname "/home/lars/src/emacs-cl/contrib/gcl-ansi-tests/") 15 | *print-length* 100 16 | *compile-verbose* t 17 | *load-verbose* t) 18 | (load "gclload.lsp") 19 | 20 | Run the tests: (in-package :cl-test) (do-tests) 21 | 22 | Loading load-cl.el (or any other file) twice may well not work. 23 | Individual functions can usually be redefined (with M-C-x or similar), 24 | but to reload the whole system, restart Emacs and load load-cl.el. 25 | 26 | To see the Emacs Lisp code generated by the compiler: 27 | (el:|compile2| (... Common Lisp code ...)) 28 | -------------------------------------------------------------------------------- /HOWTO: -------------------------------------------------------------------------------- 1 | CALLING AN EMACS LISP FUNCTION FROM COMMON LISP 2 | =============================================== 3 | 4 | All Emacs Lisp symbols are accessible from the EMACS-LISP package 5 | nicknamed EL. Remember that by default, Common Lisp converts symbol 6 | names to upper case, so use | to prevent that. For example, to print 7 | a message in the echo area: 8 | 9 | (el:|message| "Hello Emacs!") 10 | 11 | 12 | WRITING AN INTERACTIVE EMACS COMMAND 13 | ==================================== 14 | 15 | Enter these functions at the interactive prompt: 16 | 17 | (defun fac (n) (if (< n 2) 1 (* n (fac (1- n))))) 18 | 19 | (defun el:|my-fun| (n) 20 | "Print n!" 21 | (declare (interactive "nEnter a number: ")) 22 | (el:|message| (format nil "~D! is ~D" n (fac n)))) 23 | 24 | Now, try it with "M-x my-fun". 25 | 26 | 27 | CALLING A COMMON LISP FUNCTION FROM EMACS LISP 28 | ============================================== 29 | 30 | If it's a standard Common Lisp function, it's probably available in 31 | Emacs Lisp with an all-uppercase name. For example 32 | 33 | (READ-FROM-STRING "#.(+ 1 2)") 34 | => 3 35 | 36 | Otherwise, you'll find the symbol in the package in which you defined 37 | the function. For example, if you defined the function above at the 38 | "COMMON-LISP-USER>" prompt: 39 | 40 | (FIND-SYMBOL "FAC" "CL-USER") 41 | 42 | For easy access from Emacs Lisp, you may store the function in a local 43 | symbol: 44 | 45 | (fset 'fac (symbol-function (FIND-SYMBOL "FAC" "CL-USER"))) 46 | 47 | Now you can call (fac 10). 48 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | TODO: Write proper installation instructions. 2 | 3 | To load the files, load load-cl.el into Emacs. Warning: Loading the 4 | last file, populate.el, will take a long time, especially on slow 5 | computers. 6 | 7 | It's important to compile the files for improved speed. To do this, 8 | type "M-x compile-cl". A Makefile is also included, so you can just 9 | type "make" at a shell. 10 | 11 | The code is frequently verified to work with GNU Emacs 20.7 and 21.3, 12 | and XEmacs 21.4. 13 | 14 | To start an interactive session, type "M-x emacs-cl". 15 | 16 | With the "emacs-cl" script, it's also possible to run Emacs Common 17 | Lisp in batch mode. 18 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | VERSION = 0.5 2 | CONTENT_DIR = emacs-cl-$(VERSION) 3 | CONTENT_TAR = $(CONTENT_DIR).tar 4 | 5 | package: $(CONTENT_TAR) 6 | 7 | $(CONTENT_TAR): $(CONTENT_DIR) 8 | tar cf $@ $< 9 | 10 | $(CONTENT_DIR): emacs-cl-pkg.el Makefile 11 | rm -rf $(CONTENT_DIR) 12 | mkdir $(CONTENT_DIR) 13 | sed "s/VERSION/$(VERSION)/" < $< > $(CONTENT_DIR)/$< 14 | cp README $(CONTENT_DIR) 15 | cp COPYING $(CONTENT_DIR) 16 | cp src/* $(CONTENT_DIR) 17 | 18 | clean: 19 | $(MAKE) -C src clean 20 | rm -rf $(CONTENT_DIR) $(CONTENT_TAR) 21 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Emacs Common Lisp is an implementation of Common Lisp, written in 2 | Emacs Lisp. It does not yet purport to conform to the ANSI standard 3 | since, among other things, CLOS, and pretty printing are missing. 4 | However, most other Common Lisp features like lexical closures, 5 | packages, readtables, multiple values, bignums, adjustable arrays, 6 | etc, are present. At this stage many bugs remain and error checking 7 | is sparse. 8 | 9 | This implementation provides a Common Lisp environment, separate from 10 | Emacs Lisp, running in Emacs. It does not intend to extend Emacs Lisp 11 | with Common Lisp functionality; however, Common Lisp functions compile 12 | to byte code, so Emacs Lisp functions can call Common Lisp functions 13 | and vice versa. 14 | 15 | All Emacs Lisp data can be passed unchanged to Common Lisp functions, 16 | except vectors, which are used to implement various Common Lisp types 17 | not present in Emacs Lisp. An Emacs Lisp vector should be converted 18 | to a Common Lisp vector by calling cl-vector. 19 | 20 | To convert a Common Lisp vector back to Emacs Lisp, call el-vector. 21 | Common Lisp strings and bit vectors should be converted by el-string 22 | and el-bool-vector or el-bit-vector (depending on your Emacs flavour). 23 | 24 | There is a mailing list for discussion about Emacs Common Lisp. Go to 25 | http://mailman.nocrew.org/cgi-bin/mailman/listinfo/emacs-cl to subscribe. 26 | 27 | See INSTALL for usage instructions. See HOWTO for some hints on how 28 | to do common tasks. 29 | 30 | Some algorithms and messages are from SBCL and Gareth McCaughan. 31 | Notes on the internals of the implementation follows: 32 | 33 | 34 | 35 | Mapping from Emacs Lisp object types to Common Lisp object types: 36 | 37 | EL type CL type 38 | bit-vector (XEmacs) simple-bit-vector 39 | bool-vector (GNU Emacs) simple-bit-vector 40 | character (XEmacs) character 41 | compiled-function compiled-function 42 | cons cons 43 | float single-float 44 | hash-table hash-table 45 | integer fixnum 46 | string simple-string 47 | subr compiled-function 48 | symbol symbol 49 | vector various, type in first element 50 | 51 | Common Lisp objects represented by Emacs Lisp vectors: 52 | 53 | bignum [BIGNUM ...] 54 | ratio [RATIO ] 55 | complex [COMPLEX ] 56 | character [CHARACTER ] 57 | string [STRING ] 58 | char-array [char-array ] 59 | bit-vector [BIT-VECTOR ] 60 | bit-array [bit-array ] 61 | simple-vector [SIMPLE-VECTOR ...] 62 | vector [VECTOR ] 63 | array [ARRAY ] 64 | interpreted-function [INTERPRETED-FUNCTION ] 65 | instance of class C [C ...] 66 | 67 | 68 | 69 | Emacs feature wish list: 70 | 71 | * Hash tables. Done in later versions. 72 | 73 | * Weak hash tables. Done in later versions. 74 | 75 | * A function that returns the address of an object, for implementing 76 | print-unreadable-object :identity t. 77 | 78 | * A function that returns the amount of processor time used, for 79 | implementing get-internal-run-time. 80 | 81 | * A way to portably embed information in byte-code objects. 82 | 83 | 84 | 85 | There are problems with the cl:function macro when its output appears 86 | in compiled files: 87 | 88 | * When applied to a byte-code function the result will be printed 89 | with the #[...] syntax. That works, but separate invokations of 90 | cl:function will result in distinct, though equal, code vectors. 91 | 92 | * When's applied to a subr, the result will be printed with the 93 | # syntax, which will raise a syntax error when loaded. 94 | 95 | In general, Emacs' byte compiler doesn't preserve object identity, 96 | which is a problem. Here's another case: 97 | 98 | * This merges the two distinct strings into one object: 99 | (byte-compile `(lambda () (foo ,(copy-seq "abc") ,(copy-seq "abc")))) 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | emacs-cl 2 | ======== 3 | 4 | Emacs Common Lisp is an implementation of Common Lisp, written in Emacs Lisp. -------------------------------------------------------------------------------- /contrib/closette/README: -------------------------------------------------------------------------------- 1 | From: Marco Gidde 2 | Date: 18 Apr 2004 00:15:04 +0200 3 | 4 | Here we go! 5 | 6 | What is Closette? 7 | 8 | This answer is taken from the source file: 9 | ;;; Closette is an implementation of a subset of CLOS with a metaobject 10 | ;;; protocol as described in "The Art of The Metaobject Protocol", 11 | ;;; MIT Press, 1991. 12 | 13 | Since Closette is a subset of CLOS there are several restrictions. The 14 | following were found by chance: 15 | 16 | 1. It is not possible to redefine a class 17 | 2. DEFGENERIC does not know the :method option (this happens very 18 | early when loading the gcl-ansi-tests) 19 | Probably lots more ... 20 | 21 | The current version of Emacs Common Lisp must be slightly modified to 22 | run with Closette. PRINT-OBJECT should be a generic function but is 23 | defined as a normal function in emacs-cl. At the time PRINT-OBJECT is 24 | defined in Closette, there is at least one call to REMOVE-IF-NOT which 25 | calles REMOVE-IF with the COMPLEMENTed function, but the latter uses 26 | PRINT-OBJECT and this leads to an endless recursion. So COMPLEMENT 27 | must be redefined without the use of PRINT-OBJECT. 28 | 29 | To use Closette 30 | 31 | (load "closette.lisp") 32 | (use-package :closette) 33 | 34 | should be sufficient. There is a hint in the source file that one 35 | should not try to compile Closette. I don't know why and I did not 36 | try. 37 | 38 | The tests within closette-tests.lisp should not be taken too 39 | literally. It is not a real test suite but a collection of definitions 40 | where the expected results are added as comments. These are sometimes 41 | wrong. Comparing the outputs of emacs-cl and CLisp running those tests 42 | showed essentially one difference (line 744) and CLisp seems to be 43 | right there. 44 | 45 | I would finish this with "Have fun", but Closette is very slow under 46 | emacs-cl, so it is actually a GREAT fun if you are only masochistic 47 | enough. 48 | -------------------------------------------------------------------------------- /contrib/gabriel/CHANGES: -------------------------------------------------------------------------------- 1 | I got this set of files from the CMU AI repository. I wish there were 2 | more directions, but I can see none. It looks like the master file is the 3 | makefile, even though it can only work on unix systems, not on, say, 4 | Explorers. Consequently, I added the benchmark and cl-vs-tcl.lisp files, 5 | the latter of which is particular for my purposes. The only files I have 6 | added are that one and this one. 7 | 8 | I made the following modifications to the files: 9 | 10 | 1. In fft-mod and fft, wherever #+KCL, #+Lucid and #+excl were used, I added a 11 | #+Explorer and #+Lispworks. 12 | 13 | 2. In the `browse-init' function in browse.cl, I renamed an inner loop variable 14 | from `i' to `k' because, for some reason, the Explorer compiler seemed to be 15 | making a mistake, resulting in a run-time error. The new loop: 16 | 17 | (do ((k i (the fixnum (1- k)))) 18 | ((= k 0)) 19 | (declare (type fixnum k)) 20 | (setf (get name (gensym)) nil)) 21 | 22 | 3. I modified the make-declare.lisp file to put its definitions in the :user 23 | package. It originally put them in the SI package, but that's not portable 24 | Common Lisp. To be more exact, it makes it difficult to load the cl-vs-tcl 25 | file because that file references functions in the SI package defined by 26 | make-declare, but that file hasn't been loaded yet, so the package doesn't 27 | exist, and so the load fails. Other solutions are possible, but I like this 28 | better. 29 | 30 | Scott D. Anderson 31 | anderson@cs.umass.edu 32 | May 30, 1995 33 | 34 | -------------------------------------------------------------------------------- /contrib/gabriel/README: -------------------------------------------------------------------------------- 1 | To run the benchmarks start lisp, load benchmark.lisp and call the function 2 | (benchmark). For more info see the benchmark.lisp file. 3 | -------------------------------------------------------------------------------- /contrib/gabriel/benchmark.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode:Common-Lisp; Package:cl-user; Fonts:(medfnt courierfb hl12i tr12 medfnb cptfonti hl12b); Base:10 -*- 2 | ;;;; *-* File: /usr/users/eksl/systems/mess/gabriel/benchmark.lisp *-* 3 | ;;;; *-* Last-edit: Friday, June 2, 1995 15:07:05; Edited-By: anderson *-* 4 | ;;;; *-* Machine: Christa (Explorer II, Microcode 489) *-* 5 | ;;;; *-* Software: TI Common Lisp System 6.49 *-* 6 | ;;;; *-* Lisp: TI Common Lisp System 6.49 *-* 7 | 8 | ;;;; ************************************************************************** 9 | ;;;; ************************************************************************** 10 | ;;;; * * 11 | ;;;; * Running Gabriel's Benchmarks * 12 | ;;;; * * 13 | ;;;; ************************************************************************** 14 | ;;;; ************************************************************************** 15 | ;;; 16 | ;;; Written by: Scott D. Anderson 17 | ;;; Experimental Knowledge Systems Laboratory 18 | ;;; Paul R. Cohen, Principal Investigator 19 | ;;; David L. Westbrook, Systems Manager 20 | ;;; David M. Hart, Laboratory Manager 21 | ;;; Department of Computer Science 22 | ;;; University of Massachusetts 23 | ;;; Amherst, Massachusetts 01003. 24 | ;;; 25 | ;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 26 | ;;; 27 | ;;; 02-18-95 File Created. (anderson) 28 | ;;; 09-97 Made some changes to make things easier to use. (Westy) 29 | ;;; 30 | ;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 31 | ;;; --*-- 32 | 33 | (in-package :COMMON-LISP-USER) 34 | 35 | ;;; --*-- 36 | ;;; *************************************************************************** 37 | ;;; This file is similar to the makefile that is distributed with Gabriel's 38 | ;;; benchmarks. I wrote it because the Makefile approach will not work with the 39 | ;;; Explorer, and I don't know how the Explorer timings were gotten, if, indeed, 40 | ;;; any Explorer timings were done. It iterates over all the test files, 41 | ;;; proclaiming them, compiling them, loading them, and running the test 42 | ;;; functions. All of this is pretty much as the makefile does. 43 | 44 | ;;; Since I want to control what package the test file is compiled and loaded 45 | ;;; in, I needed to modify the code in test-help.lsp. Rather than make a 46 | ;;; separate file, I implemented that code in this file, so this file duplicates 47 | ;;; the test-help file in addition to the makefile. 48 | 49 | ;;; Thus, this is the master file for getting timings on almost any Lisp system. 50 | ;;; To use it, do the following: 51 | 52 | ;;; 1. Load this file 53 | ;;; 2. Run (benchmarks) to output to standard-output or 54 | ;;; (benchmarks :output ) to send output to a file. 55 | 56 | ;;; The pathname tells Lisp what to merge the filename with to get a pathname 57 | ;;; acceptable to `compile' or `load.' The output filename says where to print 58 | ;;; the results; the default is standard output. The `package' is the package 59 | ;;; to compile and load the benchmarks in. 60 | 61 | (defparameter *files* 62 | '(boyer browse ctak dderiv deriv destru-mod destru div2 fft-mod 63 | fft #+ignore fprint #+ignore fread frpoly 64 | ;; puzzle-mod puzzle 65 | puzzle-mod-noproclaim puzzle-noproclaim 66 | stak tak-mod tak takl takr #+ignore tprint traverse triang-mod 67 | triang) 68 | "Names of the files of benchmark functions.") 69 | 70 | (defparameter *gabriel-root-pathname* 71 | (let ((pathname-dir 72 | (cond (*load-truename* (pathname-directory *load-truename*)) 73 | #+MCL 74 | ((pathname-directory *loading-file-source-file*)) 75 | (t nil)))) 76 | (when pathname-dir (make-pathname :directory pathname-dir)))) 77 | 78 | (defun benchmark (&key (directory *gabriel-root-pathname*) output) 79 | "`directory' is merged with the filenames to yield a pathname to load the benchmark code from; it defaults 80 | to the directory this file is loaded in. `Output' is a filename where the results are put; it's also 81 | merged with the `directory.' If it is omitted, the results go to standard output." 82 | (let ((pkg :common-lisp-user)) ; changed from user - Westy - 3/27/96 83 | (let ((*package* (find-package pkg))) 84 | (make-compile directory) 85 | (let ((stream (if output 86 | (open (merge-pathnames output directory) :direction :output) 87 | *standard-output*))) 88 | (unwind-protect 89 | (progn 90 | (format stream "~&------------- SESSION --------------------~%") 91 | (format stream "Lisp implementation type: ~s~%" (lisp-implementation-type)) 92 | (format stream "Lisp implementation version: ~s~%" (lisp-implementation-version)) 93 | (format stream "Machine type: ~s~%" (machine-type)) 94 | (format stream "Machine version: ~s~%" (machine-version)) 95 | (format stream "Machine instance: ~s~%" (machine-instance)) 96 | (format stream "Software type: ~s~%" (software-type)) 97 | (format stream "Software version: ~s~%" (software-version)) 98 | (format stream "Short site name: ~s~%" (short-site-name)) 99 | (format stream "In Package: ~s~2%" pkg) 100 | (format stream "~2%") 101 | (make-test stream)) 102 | (if output (close stream))))))) 103 | 104 | (defun make-compile (dirname) 105 | (load (merge-pathnames "make-declare.lsp" dirname)) 106 | (dolist (v *files*) 107 | (let ((f (merge-pathnames (format nil "~(~a~).cl" v) dirname))) 108 | (let (#+Explorer (SI:INHIBIT-FDEFINE-WARNINGS t)) 109 | (format t "~&Proclaiming ~s~%" f) 110 | (proclaim-file f) 111 | (format t "~&Compiling and loading ~s~%" f) 112 | (load (compile-file f)))) 113 | #+ignore 114 | (y-or-n-p "Go on?"))) 115 | 116 | (defun make-test (stream) 117 | (dolist (v *files*) 118 | (do-test v stream))) 119 | 120 | (defvar *repeats* '((destru 4) (destru-mod 4) (fprint 4) (fread 4) 121 | (stak 4) (takr 4) (tprint 4))) 122 | 123 | (defparameter *repetitions* 1) 124 | 125 | (defparameter *all-or-summary* :summary) 126 | 127 | (defun do-test (file stream) 128 | (let ((command (let ((pos (position #\- (string file)))) 129 | (intern 130 | (concatenate 'string "TEST" 131 | (if pos 132 | (subseq (string file) 0 pos) 133 | (string file))) 134 | *package*)))) 135 | #+Explorer 136 | (gc-immediately) 137 | #+Lispworks 138 | (mark-and-sweep 0) 139 | #+Allegro 140 | (excl:gc t) 141 | #+MCL 142 | (gc) 143 | (if (= *repetitions* 1) 144 | (format stream "~%~:@(~a~)~,12t~,3f" file (timeit command file)) 145 | (loop repeat *repetitions* 146 | collect (timeit command file) into times 147 | finally 148 | (setf times (sort times #'<)) 149 | (ecase *all-or-summary* 150 | (:all 151 | (format stream "~%~:@(~a~)~,12t~{ ~,3f~}" file times)) 152 | (:summary 153 | (format stream "~%~:@(~a~)~,12t~,3f ~,3f ~,3f" 154 | file 155 | (nth 0 times) 156 | (nth (1- *repetitions*) times) 157 | ;; median 158 | (if (oddp *repetitions*) 159 | (nth (floor *repetitions* 2) times) 160 | (/ (+ (nth (1- (floor *repetitions* 2)) times) 161 | (nth (floor *repetitions* 2) times)) 162 | 2))))))))) 163 | 164 | (defun timeit (command file) 165 | (let ((n (or (cadr (assoc file *repeats*)) 1))) 166 | (format t "~&Calling ~s ~d time~:p~%" command n) 167 | (let ((start (get-internal-run-time))) 168 | (dotimes (i n) (funcall command)) 169 | (/ (/ (float (- (get-internal-run-time) start)) n) 170 | (float internal-time-units-per-second))))) 171 | 172 | ;;; ================================================================ 173 | 174 | #+OLD 175 | (defun min-max-median () 176 | (with-open-file (cl1 "lw-cl-1.text") 177 | (with-open-file (cl2 "lw-cl-2.text") 178 | (with-open-file (tcl "lw-tcl-1.text") 179 | (with-open-file (tcw "lw-cw-1.text") 180 | (loop repeat 10 do 181 | (read-line cl1) 182 | (read-line cl2) 183 | (read-line tcl) 184 | (read-line tcw)) 185 | (loop for cl1x = (read cl1 nil) 186 | for cl2x = (read cl2 nil) 187 | for tclx = (read tcl nil) 188 | for tcwx = (read tcw nil) 189 | for cl1y = (read cl1 nil) 190 | for cl2y = (read cl2 nil) 191 | for tcly = (read tcl nil) 192 | for tcwy = (read tcw nil) 193 | do 194 | (when (null cl1x) (loop-finish)) 195 | (unless (and (eq cl1x cl2x) (eq cl2x tclx) (eq tclx tcwx)) 196 | (error "out of synch: ~s ~s ~s ~s" cl1x cl2x tclx tcwx)) 197 | (format t "~(~a~) ~25t & ~5,3f & ~5,3f & ~5,3f & ~5,3f & ~3,1f & ~3,1f \\\\~%" 198 | cl1x 199 | cl1y 200 | cl2y 201 | tcly 202 | tcwy 203 | (/ tcly (/ (+ cl1y cl2y) 2)) 204 | (/ tcwy (/ (+ cl1y cl2y) 2))))))))) 205 | 206 | ;;; *************************************************************************** 207 | ;;; EOF 208 | -------------------------------------------------------------------------------- /contrib/gabriel/browse.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/browse.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; BROWSE -- Benchmark to create and browse through an AI-like data base 5 | ;;; of units. 6 | 7 | ;;; n is # of symbols 8 | ;;; m is maximum amount of stuff on the plist 9 | ;;; npats is the number of basic patterns on the unit 10 | ;;; ipats is the instantiated copies of the patterns 11 | 12 | (eval-when (eval compile) 13 | (defvar *browse-rand* 21) 14 | (proclaim '(type fixnum *browse-rand*)) 15 | (defconstant *browse-star* (code-char 42)) 16 | (defconstant *browse-questionmark* (code-char 63))) 17 | 18 | (eval-when (eval compile) 19 | ;; maybe SYMBOL-NAME 20 | (defmacro browse-char1 (x) `(schar (symbol-name ,x) 0))) 21 | 22 | 23 | (defun browse-init (n m npats ipats) 24 | (declare (type fixnum n m npats)) 25 | (setq *browse-rand* 21) 26 | (let ((ipats (copy-tree ipats))) 27 | (do ((p ipats (cdr p))) 28 | ((null (cdr p)) (rplacd p ipats))) 29 | (do ((n n (the fixnum (1- n))) 30 | (i m (cond ((= i 0) m) 31 | (t (the fixnum (1- i))))) 32 | (name (gentemp) (gentemp)) 33 | (a ())) 34 | ((= n 0) a) 35 | (declare (type fixnum n i)) 36 | (push name a) 37 | (do ((k i (the fixnum (1- k)))) 38 | ((= k 0)) 39 | (declare (type fixnum k)) 40 | (setf (get name (gensym)) nil)) 41 | (setf (get name 'pattern) 42 | (do ((i npats (the fixnum (1- i))) 43 | (ipats ipats (cdr ipats)) 44 | (a ())) 45 | ((= i 0) a) 46 | (declare (type fixnum i)) 47 | (push (car ipats) a))) 48 | (do ((j (the fixnum (- m i)) (the fixnum (1- j)))) 49 | ((= j 0)) 50 | (declare (type fixnum j)) 51 | (setf (get name (gensym)) nil))))) 52 | 53 | 54 | (defun browse-random () 55 | (setq *browse-rand* (rem (the fixnum (* *browse-rand* 17)) 251))) 56 | 57 | (defun browse-randomize (l) 58 | (do ((a ())) 59 | ((null l) a) 60 | (let ((n (rem (the fixnum (browse-random)) (the fixnum (length l))))) 61 | (declare (type fixnum n)) 62 | (cond ((= n 0) 63 | (push (car l) a) 64 | (setq l (cdr l))) 65 | (t 66 | (do ((n n (the fixnum (1- n))) 67 | (x l (cdr x))) 68 | ((= n 1) 69 | (push (cadr x) a) 70 | (rplacd x (cddr x))) 71 | (declare (type fixnum n)))))))) 72 | 73 | (defun match (pat dat alist) 74 | (cond ((null pat) 75 | (null dat)) 76 | ((null dat) ()) 77 | ((or (eq (car pat) '?) 78 | (eq (car pat) 79 | (car dat))) 80 | (match (cdr pat) (cdr dat) alist)) 81 | ((eq (car pat) '*) 82 | (or (match (cdr pat) dat alist) 83 | (match (cdr pat) (cdr dat) alist) 84 | (match pat (cdr dat) alist))) 85 | (t (cond ((atom (car pat)) 86 | ;;replace eq by 'eql for char 87 | (cond ((eql (browse-char1 (car pat)) 88 | *browse-questionmark*) 89 | (let ((val (assoc (car pat) alist))) 90 | (cond (val (match (cons (cdr val) 91 | (cdr pat)) 92 | dat alist)) 93 | (t (match (cdr pat) 94 | (cdr dat) 95 | (cons (cons (car pat) 96 | (car dat)) 97 | alist)))))) 98 | ((eql (browse-char1 (car pat)) *browse-star*) 99 | (let ((val (assoc (car pat) alist))) 100 | (cond (val (match (append (cdr val) 101 | (cdr pat)) 102 | dat alist)) 103 | (t 104 | (do ((l () (nconc l (cons (car d) nil))) 105 | (e (cons () dat) (cdr e)) 106 | (d dat (cdr d))) 107 | ((null e) ()) 108 | (cond ((match (cdr pat) d 109 | (cons (cons (car pat) l) 110 | alist)) 111 | (return t)))))))))) 112 | (t (and 113 | (not (atom (car dat))) 114 | (match (car pat) 115 | (car dat) alist) 116 | (match (cdr pat) 117 | (cdr dat) alist))))))) 118 | 119 | (defun browse () 120 | (investigate (browse-randomize 121 | (browse-init 100 10 4 '((a a a b b b b a a a a a b b a a a) 122 | (a a b b b b a a 123 | (a a)(b b)) 124 | (a a a b (b a) b a b a)))) 125 | '((*a ?b *b ?b a *a a *b *a) 126 | (*a *b *b *a (*a) (*b)) 127 | (? ? * (b a) * ? ?)))) 128 | 129 | (defun investigate (units pats) 130 | (do ((units units (cdr units))) 131 | ((null units)) 132 | (do ((pats pats (cdr pats))) 133 | ((null pats)) 134 | (do ((p (get (car units) 'pattern) 135 | (cdr p))) 136 | ((null p)) 137 | (match (car pats) (car p) ()))))) 138 | 139 | (defun testbrowse () 140 | (print (time (browse)))) 141 | -------------------------------------------------------------------------------- /contrib/gabriel/control.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/control.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; 3 | ;; benchmark control 4 | 5 | (setf (comp:target-fpp) :m68881) 6 | (setq comp::*target-architecture* :mc68020) 7 | (setf (sys:gsgc-parameter :generation-spread) 4) 8 | 9 | (require :foreign) 10 | (use-package :ff) 11 | (load "time.o") 12 | 13 | (defforeign 'get_time 14 | :entry-point (convert-to-lang "get_time" :language :c) 15 | :arguments '(t)) 16 | 17 | (import '(lisp::time-utime-sec lisp::time-utime-usec lisp::time-stime-sec 18 | lisp::time-stime-usec lisp::time-stime-minflt 19 | lisp::time-stime-majflt lisp::time-stime-maxrss 20 | lisp::time-real-sec lisp::time-real-usec)) 21 | 22 | (defcstruct time 23 | (utime-sec :unsigned-long) 24 | (utime-usec :unsigned-long) 25 | (stime-sec :unsigned-long) 26 | (stime-usec :unsigned-long) 27 | (stime-minflt :unsigned-long) 28 | (stime-majflt :unsigned-long) 29 | (stime-maxrss :unsigned-long) 30 | (real-sec :unsigned-long) 31 | (real-usec :unsigned-long)) 32 | 33 | (defmacro bm-time-macro (form) 34 | `(let ((start (make-time)) (end (make-time))) 35 | (get_time start) 36 | (multiple-value-prog1 ,form 37 | (get_time end) 38 | (print-time start end)))) 39 | 40 | (defun print-time (start end) 41 | (let* ((u1 (truncate (+ (* 1000000 (time-utime-sec start)) 42 | (time-utime-usec start)) 43 | 1000)) 44 | (s1 (truncate (+ (* 1000000 (time-stime-sec start)) 45 | (time-stime-usec start)) 46 | 1000)) 47 | (u2 (truncate (+ (* 1000000 (time-utime-sec end)) 48 | (time-utime-usec end)) 49 | 1000)) 50 | (s2 (truncate (+ (* 1000000 (time-stime-sec end)) 51 | (time-stime-usec end)) 52 | 1000)) 53 | (r1 (truncate (+ (* 1000000 (time-real-sec start)) 54 | (time-real-usec start)) 55 | 1000)) 56 | (r2 (truncate (+ (* 1000000 (time-real-sec end)) 57 | (time-real-usec end)) 58 | 1000)) 59 | (page-faults (- (+ (time-stime-majflt end) 60 | (time-stime-minflt end)) 61 | (+ (time-stime-minflt start) 62 | (time-stime-majflt start)))) 63 | (real (- r2 r1)) 64 | (user (- u2 u1)) 65 | (system (- s2 s1))) 66 | (format *trace-output* 67 | " 68 | (~10:<~d~> ;; non-gc user 69 | ~10:<~d~> ;; non-gc system 70 | ~10:<~d~> ;; gc user 71 | ~10:<~d~> ;; gc system 72 | ~10:<~d~> ;; total user 73 | ~10:<~d~> ;; total gc 74 | ~10:<~d~> ;; real 75 | ~10:<~d~> ;; max rss size (pages) 76 | ~10:<~d~> ;; page faults 77 | )" 78 | user system 0 0 user 0 real 79 | (time-stime-maxrss end) page-faults))) 80 | 81 | (defparameter *benches* 82 | '(boyer 83 | browse 84 | ctak 85 | dderiv 86 | deriv 87 | destru 88 | (div2 div2-iter div2-recur) 89 | fft 90 | fprint 91 | fread 92 | (frpoly frpoly-1 frpoly-2 frpoly-3 frpoly-4) 93 | puzzle 94 | stak 95 | tak 96 | takl 97 | takr 98 | tprint 99 | (traverse traverse-init traverse-run) 100 | triang)) 101 | 102 | (defun compile-all-bms (&optional (result-file "results.compile")) 103 | (let ((old-time (macro-function 'time))) 104 | (setf (macro-function 'time) (macro-function 'bm-time-macro)) 105 | (let ((*trace-output* 106 | (open result-file :direction :output :if-exists :supersede))) 107 | (format *trace-output* "(:benchmark-compilation~%") 108 | (gc :tenure) 109 | (bm-time-macro 110 | (dolist (bench *benches*) 111 | (if (consp bench) (setq bench (car bench))) 112 | (setq bench (string-downcase (string bench))) 113 | (compile-file (merge-pathnames (make-pathname :type "cl") bench)))) 114 | (format *trace-output* ")~%") 115 | (close *trace-output*)) 116 | (setf (macro-function 'time) old-time) 117 | nil)) 118 | 119 | (defun run-all-bms (&optional (result-file "results.run")) 120 | (let ((*trace-output* 121 | (open result-file :direction :output :if-exists :append))) 122 | (dolist (bench *benches*) 123 | (run-bench bench)) 124 | (close *trace-output*))) 125 | 126 | (defun run-bench (bench &aux name function) 127 | (cond 128 | ((consp bench) 129 | ;; the form of bench is 130 | ;; (file name1 name2 ...) 131 | (load (string-downcase (symbol-name (car bench)))) 132 | (dolist (name (cdr bench)) 133 | (run-bench-1 name (find-symbol (format nil "~a~a" 'test name))))) 134 | (t (load (string-downcase (symbol-name bench))) 135 | (run-bench-1 bench (find-symbol (format nil "~a~a" 'test bench)))))) 136 | 137 | (defun run-bench-1 (bench function) 138 | (format *trace-output* "~%(:~a~%" bench) 139 | (dotimes (n 3) 140 | (gc :tenure) 141 | (funcall function)) 142 | (format *trace-output* ")~%") 143 | (force-output *trace-output*)) 144 | 145 | (defun run-benches (&rest bench-list) 146 | (mapc #'(lambda (bench) (apply #'run-bench bench)) bench-list)) 147 | -------------------------------------------------------------------------------- /contrib/gabriel/ctak.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/ctak.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. 5 | 6 | (defun ctak (x y z) 7 | (catch 'ctak (ctak-aux x y z))) 8 | 9 | (defun ctak-aux (x y z) 10 | (declare (type fixnum x y z)) 11 | (cond ((not (< y x)) 12 | (throw 'ctak z)) 13 | (t (ctak-aux 14 | (catch 'ctak 15 | (ctak-aux (the fixnum (1- x)) 16 | y 17 | z)) 18 | (catch 'ctak 19 | (ctak-aux (the fixnum (1- y)) 20 | z 21 | x)) 22 | (catch 'ctak 23 | (ctak-aux (the fixnum (1- z)) 24 | x 25 | y)))))) 26 | 27 | (defun testctak () 28 | (print (time (ctak 18 12 6)))) 29 | -------------------------------------------------------------------------------- /contrib/gabriel/dderiv.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/dderiv.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt. 5 | 6 | ;;; This benchmark is a variant of the simple symbolic derivative program 7 | ;;; (DERIV). The main change is that it is `table-driven.' Instead of using a 8 | ;;; large COND that branches on the CAR of the expression, this program finds 9 | ;;; the code that will take the derivative on the property list of the atom in 10 | ;;; the CAR position. So, when the expression is (+ . ), the code 11 | ;;; stored under the atom '+ with indicator DERIV will take and 12 | ;;; return the derivative for '+. The way that MacLisp does this is with the 13 | ;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an 14 | ;;; atomic name in that it expects an argument list and the compiler compiles 15 | ;;; code, but the name of the function with that code is stored on the 16 | ;;; property list of FOO under the indicator BAR, in this case. You may have 17 | ;;; to do something like: 18 | 19 | ;;; :property keyword is not Common Lisp. 20 | 21 | (defun dderiv-aux (a) 22 | (list '// (dderiv a) a)) 23 | 24 | (defun +dderiv (a) 25 | (cons '+ (mapcar 'dderiv a))) 26 | 27 | (defun -dderiv (a) 28 | (cons '- (mapcar 'dderiv a))) 29 | 30 | (defun *dderiv (a) 31 | (list '* (cons '* a) 32 | (cons '+ (mapcar 'dderiv-aux a)))) 33 | 34 | (defun //dderiv (a) 35 | (list '- 36 | (list '// 37 | (dderiv (car a)) 38 | (cadr a)) 39 | (list '// 40 | (car a) 41 | (list '* 42 | (cadr a) 43 | (cadr a) 44 | (dderiv (cadr a)))))) 45 | 46 | (mapc #'(lambda (op fun) (setf (get op 'dderiv) (symbol-function fun))) 47 | '(+ - * //) 48 | '(+dderiv -dderiv *dderiv //dderiv)) 49 | 50 | (defun dderiv (a) 51 | (cond 52 | ((atom a) 53 | (cond ((eq a 'x) 1) (t 0))) 54 | (t (let ((dderiv (get (car a) 'dderiv))) 55 | (cond (dderiv (funcall dderiv (cdr a))) 56 | (t 'error)))))) 57 | 58 | (defun dderiv-run () 59 | (do ((i 0 (the fixnum (1+ i)))) 60 | ((= (the fixnum i) 1000.)) 61 | (declare (type fixnum i)) 62 | (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) 63 | (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) 64 | (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) 65 | (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) 66 | (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) 67 | 68 | (defun testdderiv () 69 | (print (time (dderiv-run)))) 70 | -------------------------------------------------------------------------------- /contrib/gabriel/deriv.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/deriv.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt. 5 | ;;; It uses a simple subset of Lisp and does a lot of CONSing. 6 | 7 | (defun deriv-aux (a) (list '/ (deriv a) a)) 8 | 9 | (defun deriv (a) 10 | (cond 11 | ((atom a) 12 | (cond ((eq a 'x) 1) (t 0))) 13 | ((eq (car a) '+) 14 | (cons '+ (mapcar #'deriv (cdr a)))) 15 | ((eq (car a) '-) 16 | (cons '- (mapcar #'deriv (cdr a)))) 17 | ((eq (car a) '*) 18 | (list '* 19 | a 20 | (cons '+ (mapcar #'deriv-aux (cdr a))))) 21 | ((eq (car a) '/) 22 | (list '- 23 | (list '/ 24 | (deriv (cadr a)) 25 | (caddr a)) 26 | (list '/ 27 | (cadr a) 28 | (list '* 29 | (caddr a) 30 | (caddr a) 31 | (deriv (caddr a)))))) 32 | (t 'error))) 33 | 34 | (defun deriv-run () 35 | (do ((i 0 (the fixnum (1+ i)))) 36 | ((= (the fixnum i) 1000.)) ;runs it 5000 times 37 | (declare (type fixnum i)) ;improves the code a little 38 | (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) 39 | (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) 40 | (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) 41 | (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) 42 | (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) 43 | 44 | (defun testderiv () 45 | (print (time (deriv-run)))) 46 | -------------------------------------------------------------------------------- /contrib/gabriel/destru-mod.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/destru-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;; DESTRU -- Destructive operation benchmark 5 | 6 | ;;mod: add fixnum declaration for n in the following let: 7 | ;; (let ((n (floor (the fixnum (length (car l1))) 2))) 8 | 9 | 10 | (defun destructive (n m) 11 | (declare (type fixnum n m)) 12 | (let ((l (do ((i 10. (the fixnum (1- i))) 13 | (a () (push () a))) 14 | ((= (the fixnum i) 0) a) 15 | (declare (type fixnum i))))) 16 | (do ((i n (the fixnum (1- i)))) 17 | ((= (the fixnum i) 0)) 18 | (declare (type fixnum i)) 19 | (cond ((null (car l)) 20 | (do ((l l (cdr l))) 21 | ((null l)) 22 | (or (car l) 23 | (rplaca l (cons () ()))) 24 | (nconc (car l) 25 | (do ((j m (the fixnum (1- j))) 26 | (a () (push () a))) 27 | ((= (the fixnum j) 0) a) 28 | (declare (type fixnum j)))))) 29 | (t 30 | (do ((l1 l (cdr l1)) 31 | (l2 (cdr l) (cdr l2))) 32 | ((null l2)) 33 | (rplacd (do ((j (floor (the fixnum (length (car l2))) 2) 34 | (the fixnum (1- j))) 35 | (a (car l2) (cdr a))) 36 | ((zerop (the fixnum j)) a) 37 | (declare (type fixnum j)) 38 | (rplaca a i)) 39 | (let ((n (floor (the fixnum (length (car l1))) 2))) 40 | (declare (type fixnum n)) 41 | (cond ((= (the fixnum n) 0) (rplaca l1 ()) 42 | (car l1)) 43 | (t 44 | (do ((j n (the fixnum (1- j))) 45 | (a (car l1) (cdr a))) 46 | ((= (the fixnum j) 1) 47 | (prog1 (cdr a) 48 | (rplacd a ()))) 49 | (declare (type fixnum j)) 50 | (rplaca a i)))))))))))) 51 | 52 | (defun testdestru () 53 | (print (time (destructive 600 50)))) 54 | -------------------------------------------------------------------------------- /contrib/gabriel/destru.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/destru.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;; DESTRU -- Destructive operation benchmark 5 | 6 | (defun destructive (n m) 7 | (declare (type fixnum n m)) 8 | (let ((l (do ((i 10. (the fixnum (1- i))) 9 | (a () (push () a))) 10 | ((= (the fixnum i) 0) a) 11 | (declare (type fixnum i))))) 12 | (do ((i n (the fixnum (1- i)))) 13 | ((= (the fixnum i) 0)) 14 | (declare (type fixnum i)) 15 | (cond ((null (car l)) 16 | (do ((l l (cdr l))) 17 | ((null l)) 18 | (or (car l) 19 | (rplaca l (cons () ()))) 20 | (nconc (car l) 21 | (do ((j m (the fixnum (1- j))) 22 | (a () (push () a))) 23 | ((= (the fixnum j) 0) a) 24 | (declare (type fixnum j)))))) 25 | (t 26 | (do ((l1 l (cdr l1)) 27 | (l2 (cdr l) (cdr l2))) 28 | ((null l2)) 29 | (rplacd (do ((j (floor (the fixnum (length (car l2))) 2) 30 | (the fixnum (1- j))) 31 | (a (car l2) (cdr a))) 32 | ((zerop (the fixnum j)) a) 33 | (declare (type fixnum j)) 34 | (rplaca a i)) 35 | (let ((n (floor (the fixnum (length (car l1))) 2))) 36 | (cond ((= (the fixnum n) 0) (rplaca l1 ()) 37 | (car l1)) 38 | (t 39 | (do ((j n (the fixnum (1- j))) 40 | (a (car l1) (cdr a))) 41 | ((= (the fixnum j) 1) 42 | (prog1 (cdr a) 43 | (rplacd a ()))) 44 | (declare (type fixnum j)) 45 | (rplaca a i)))))))))))) 46 | 47 | (defun testdestru () 48 | (print (time (destructive 600 50)))) 49 | -------------------------------------------------------------------------------- /contrib/gabriel/div2.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/div2.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. 5 | ;;; This file contains a recursive as well as an iterative test. 6 | 7 | (defun create-n (n) 8 | (declare (type fixnum n)) 9 | (do ((n n (the fixnum (1- n))) 10 | (a () (push () a))) 11 | ((= (the fixnum n) 0) a) 12 | (declare (type fixnum n)))) 13 | 14 | (defvar ll (create-n 200.)) 15 | 16 | 17 | (defun iterative-div2 (l) 18 | (do ((l l (cddr l)) 19 | (a () (push (car l) a))) 20 | ((null l) a))) 21 | 22 | (defun recursive-div2 (l) 23 | (cond ((null l) ()) 24 | (t (cons (car l) (recursive-div2 (cddr l)))))) 25 | 26 | (defun test-1 (l) 27 | (do ((i 300 (the fixnum (1- i)))) 28 | ((= (the fixnum i) 0)) 29 | (declare (type fixnum i)) 30 | (iterative-div2 l) 31 | (iterative-div2 l) 32 | (iterative-div2 l) 33 | (iterative-div2 l))) 34 | 35 | (defun test-2 (l) 36 | (do ((i 300 (the fixnum (1- i)))) 37 | ((= (the fixnum i) 0)) 38 | (declare (type fixnum i)) 39 | (recursive-div2 l) 40 | (recursive-div2 l) 41 | (recursive-div2 l) 42 | (recursive-div2 l))) 43 | 44 | (defun testdiv2 () 45 | (testdiv2-iter) 46 | (testdiv2-recur)) 47 | 48 | (defun testdiv2-iter () 49 | (print (time (test-1 ll)))) 50 | 51 | (defun testdiv2-recur () 52 | (print (time (test-2 ll)))) 53 | -------------------------------------------------------------------------------- /contrib/gabriel/fft-mod.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Common-Lisp; Base:10 -*- 2 | ;;;; *-* Last-edit: Sunday, April 30, 1995 20:30:03; Edited-By: anderson *-* 3 | 4 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/fft-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 5 | ;; $Locker: $ 6 | 7 | ;; FFT -- This is an FFT benchmark written by Harry Barrow. 8 | ;; It tests a variety of floating point operations, including array references. 9 | 10 | (defvar **fft-re** 11 | (make-array 1025. :element-type 12 | #+excl 'single-float #+lucid 'float #+KCL 'single-float 13 | #+Explorer 'single-float 14 | #+Lispworks 'single-float 15 | :initial-element 0.0)) 16 | 17 | (defvar **fft-im** 18 | (make-array 1025. :element-type 19 | #+excl 'single-float #+lucid 'single-float #+KCL 'single-float 20 | #+Explorer 'single-float 21 | #+Lispworks 'single-float 22 | :initial-element 0.0)) 23 | 24 | (defmacro ff+ (a b) 25 | `(the single-float (+ (the single-float ,a) (the single-float ,b)))) 26 | 27 | (defmacro ff*(a b) 28 | `(the single-float (* (the single-float ,a) (the single-float ,b)))) 29 | (defmacro ff-(a b) 30 | `(the single-float (- (the single-float ,a) (the single-float ,b)))) 31 | 32 | 33 | (proclaim '(type (#+KCL vector #-KCL simple-array 34 | #+excl single-float 35 | #+lucid single-float 36 | #+KCL single-float 37 | #+Explorer single-float 38 | #+Lispworks single-float 39 | (*)) 40 | **fft-re** **fft-im**)) 41 | 42 | (defvar s-pi (float pi 0.0)) 43 | (proclaim '(type #+excl single-float 44 | #+KCL single-float 45 | #+lucid single-float 46 | #+Explorer single-float 47 | #+Lispworks single-float 48 | s-pi)) 49 | 50 | (defun fft (areal aimag) 51 | (declare (type (simple-array single-float (*)) areal aimag)) 52 | (prog* ((ar areal) 53 | (ai aimag) 54 | (i 1) 55 | (j 0) 56 | (k 0) 57 | (m 0) ;compute m = log(n) 58 | (n (1- (array-dimension ar 0))) 59 | (nv2 (floor n 2)) 60 | (le 0) (le1 0) (ip 0) 61 | (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) 62 | (declare (type fixnum i j k n nv2 m le le1 ip)) 63 | (declare (type (simple-array single-float (*)) ar ai)) 64 | (declare (type single-float ur ui wr wi tr ti)) 65 | l1 (cond ((< i n) 66 | (setq m (the fixnum (1+ m)) 67 | i (the fixnum (+ i i))) 68 | (go l1))) 69 | (cond ((not (equal n (the fixnum (expt 2 m)))) 70 | (princ "error ... array size not a power of two.") 71 | (read) 72 | (return (terpri)))) 73 | (setq j 1 ;interchange elements 74 | i 1) ;in bit-reversed order 75 | l3 (cond ((< i j) 76 | (setq tr (aref ar j) 77 | ti (aref ai j)) 78 | (setf (aref ar j) (aref ar i)) 79 | (setf (aref ai j) (aref ai i)) 80 | (setf (aref ar i) tr) 81 | (setf (aref ai i) ti))) 82 | (setq k nv2) 83 | l6 (cond ((< k j) 84 | (setq j (the fixnum (- j k)) 85 | k (the fixnum (/ k 2))) 86 | (go l6))) 87 | (setq j (the fixnum (+ j k)) 88 | i (the fixnum (1+ i))) 89 | (cond ((< i n) 90 | (go l3))) 91 | (do ((l 1 (the fixnum (1+ (the fixnum l))))) 92 | ((> (the fixnum l) m)) ;loop thru stages 93 | (declare (type fixnum l)) 94 | (setq le (the fixnum (expt 2 l)) 95 | le1 (the (values fixnum fixnum) (floor le 2)) 96 | ur 1.0 97 | ui 0.0 98 | wr (cos (/ s-pi (float le1))) 99 | wi (sin (/ s-pi (float le1)))) 100 | (do ((j 1 (the fixnum (1+ (the fixnum j))))) 101 | ((> (the fixnum j) le1)) ;loop thru butterflies 102 | (declare (type fixnum j)) 103 | (do ((i j (+ (the fixnum i) le))) 104 | ((> (the fixnum i) n)) ;do a butterfly 105 | (declare (type fixnum i)) 106 | (setq ip (the fixnum (+ i le1)) 107 | tr (ff- (ff* (aref ar ip) ur) 108 | (ff* (aref ai ip) ui)) 109 | ti (ff+ (ff* (aref ar ip) ui) 110 | (ff* (aref ai ip) ur))) 111 | (setf (aref ar ip) (ff- (aref ar i) tr)) 112 | (setf (aref ai ip) (ff- (aref ai i) ti)) 113 | (setf (aref ar i) (ff+ (aref ar i) tr)) 114 | (setf (aref ai i) (ff+ (aref ai i) ti)))) 115 | (setq tr (ff- (ff* ur wr) (ff* ui wi)) 116 | ti (ff+ (ff* ur wi) (ff* ui wr)) 117 | ur tr 118 | ui ti)) 119 | (return t))) 120 | 121 | 122 | (defun fft-bench () 123 | (dotimes (i 10) 124 | (fft **fft-re** **fft-im**))) 125 | 126 | (defun testfft () 127 | (print (time (fft-bench)))) 128 | 129 | 130 | ;;; 131 | ;;; the following are for verifying that the implementation gives the 132 | ;;; correct result 133 | ;;; 134 | 135 | (defun clear-fft () 136 | (dotimes (i 1025) 137 | (setf (aref **fft-re** i) 0.0 138 | (aref **fft-im** i) 0.0)) 139 | (values)) 140 | 141 | (defun setup-fft-component (theta &optional (phase 0.0)) 142 | (let ((f (f* 2 pi theta)) 143 | (c (cos (f* 0.5 pi phase))) 144 | (s (sin (f* 0.5 pi phase)))) 145 | (dotimes (i 1025) 146 | (let ((x (sin (* f (/ i 1024.0))))) 147 | (incf (aref **fft-re** i) (float (* c x) 0.0)) 148 | (incf (aref **fft-im** i) (float (* s x) 0.0))))) 149 | (values)) 150 | 151 | (defvar fft-delta 0.0001) 152 | 153 | (defun print-fft () 154 | (dotimes (i 1025) 155 | (let ((re (aref **fft-re** i)) 156 | (im (aref **fft-im** i))) 157 | (unless (and (< (abs re) fft-delta) (< (abs im) fft-delta)) 158 | (format t "~4d ~10f ~10f~%" i re im)))) 159 | (values)) 160 | -------------------------------------------------------------------------------- /contrib/gabriel/fft.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Common-Lisp; Base:10 -*- 2 | ;;;; *-* Last-edit: Sunday, April 30, 1995 20:38:20; Edited-By: anderson *-* 3 | 4 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/fft.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 5 | ;; $Locker: $ 6 | 7 | ;; FFT -- This is an FFT benchmark written by Harry Barrow. 8 | ;; It tests a variety of floating point operations, including array references. 9 | 10 | (defvar **fft-re** 11 | (make-array 1025. :element-type 12 | #+excl 'single-float 13 | #+lucid 'float 14 | #+KCL 'single-float 15 | #+Explorer 'single-float 16 | #+Lispworks 'single-float 17 | :initial-element 0.0)) 18 | 19 | (defvar **fft-im** 20 | (make-array 1025. :element-type 21 | #+excl 'single-float 22 | #+lucid 'single-float 23 | #+KCL 'single-float 24 | #+Explorer 'single-float 25 | #+Lispworks 'single-float 26 | :initial-element 0.0)) 27 | 28 | (proclaim '(type (#+KCL vector #-KCL simple-array 29 | #+excl single-float 30 | #+lucid single-float 31 | #+KCL single-float 32 | #+Explorer single-float 33 | #+Lispworks single-float (*)) 34 | **fft-re** **fft-im**)) 35 | 36 | (defvar s-pi (float pi 0.0)) 37 | (proclaim '(type 38 | #+excl single-float 39 | #+KCL single-float 40 | #+lucid single-float 41 | #+Explorer single-float 42 | #+Lispworks single-float 43 | s-pi)) 44 | 45 | (defun fft (areal aimag) 46 | (declare (type (simple-array single-float (*)) areal aimag)) 47 | (prog* ((ar areal) 48 | (ai aimag) 49 | (i 1) 50 | (j 0) 51 | (k 0) 52 | (m 0) ;compute m = log(n) 53 | (n (1- (array-dimension ar 0))) 54 | (nv2 (floor n 2)) 55 | (le 0) (le1 0) (ip 0) 56 | (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) 57 | (declare (type fixnum i j k n nv2 m le le1 ip)) 58 | (declare (type (simple-array single-float (*)) ar ai)) 59 | (declare (type single-float ur ui wr wi tr ti)) 60 | l1 (cond ((< i n) 61 | (setq m (the fixnum (1+ m)) 62 | i (the fixnum (+ i i))) 63 | (go l1))) 64 | (cond ((not (equal n (the fixnum (expt 2 m)))) 65 | (princ "error ... array size not a power of two.") 66 | (read) 67 | (return (terpri)))) 68 | (setq j 1 ;interchange elements 69 | i 1) ;in bit-reversed order 70 | l3 (cond ((< i j) 71 | (setq tr (aref ar j) 72 | ti (aref ai j)) 73 | (setf (aref ar j) (aref ar i)) 74 | (setf (aref ai j) (aref ai i)) 75 | (setf (aref ar i) tr) 76 | (setf (aref ai i) ti))) 77 | (setq k nv2) 78 | l6 (cond ((< k j) 79 | (setq j (the fixnum (- j k)) 80 | k (the fixnum (/ k 2))) 81 | (go l6))) 82 | (setq j (the fixnum (+ j k)) 83 | i (the fixnum (1+ i))) 84 | (cond ((< i n) 85 | (go l3))) 86 | (do ((l 1 (the fixnum (1+ (the fixnum l))))) 87 | ((> (the fixnum l) m)) ;loop thru stages 88 | (declare (type fixnum l)) 89 | (setq le (the fixnum (expt 2 l)) 90 | le1 (the (values fixnum fixnum) (floor le 2)) 91 | ur 1.0 92 | ui 0.0 93 | wr (cos (/ s-pi (float le1))) 94 | wi (sin (/ s-pi (float le1)))) 95 | (do ((j 1 (the fixnum (1+ (the fixnum j))))) 96 | ((> (the fixnum j) le1)) ;loop thru butterflies 97 | (declare (type fixnum j)) 98 | (do ((i j (+ (the fixnum i) le))) 99 | ((> (the fixnum i) n)) ;do a butterfly 100 | (declare (type fixnum i)) 101 | (setq ip (the fixnum (+ i le1)) 102 | tr (- (* (aref ar ip) ur) 103 | (* (aref ai ip) ui)) 104 | ti (+ (* (aref ar ip) ui) 105 | (* (aref ai ip) ur))) 106 | (setf (aref ar ip) (- (aref ar i) tr)) 107 | (setf (aref ai ip) (- (aref ai i) ti)) 108 | (setf (aref ar i) (+ (aref ar i) tr)) 109 | (setf (aref ai i) (+ (aref ai i) ti)))) 110 | (setq tr (- (* ur wr) (* ui wi)) 111 | ti (+ (* ur wi) (* ui wr)) 112 | ur tr 113 | ui ti)) 114 | (return t))) 115 | 116 | (defun fft-bench () 117 | (dotimes (i 10) 118 | (fft **fft-re** **fft-im**))) 119 | 120 | (defun testfft () 121 | (print (time (fft-bench)))) 122 | 123 | 124 | ;;; 125 | ;;; the following are for verifying that the implementation gives the 126 | ;;; correct result 127 | ;;; 128 | 129 | (defun clear-fft () 130 | (dotimes (i 1025) 131 | (setf (aref **fft-re** i) 0.0 132 | (aref **fft-im** i) 0.0)) 133 | (values)) 134 | 135 | (defun setup-fft-component (theta &optional (phase 0.0)) 136 | (let ((f (* 2 pi theta)) 137 | (c (cos (* 0.5 pi phase))) 138 | (s (sin (* 0.5 pi phase)))) 139 | (dotimes (i 1025) 140 | (let ((x (sin (* f (/ i 1024.0))))) 141 | (incf (aref **fft-re** i) (float (* c x) 0.0)) 142 | (incf (aref **fft-im** i) (float (* s x) 0.0))))) 143 | (values)) 144 | 145 | (defvar fft-delta 0.0001) 146 | 147 | (defun print-fft () 148 | (dotimes (i 1025) 149 | (let ((re (aref **fft-re** i)) 150 | (im (aref **fft-im** i))) 151 | (unless (and (< (abs re) fft-delta) (< (abs im) fft-delta)) 152 | (format t "~4d ~10f ~10f~%" i re im)))) 153 | (values)) 154 | -------------------------------------------------------------------------------- /contrib/gabriel/fprint.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/fprint.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; FPRINT -- Benchmark to print to a file. 5 | 6 | (defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 7 | mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 8 | wxyzab23 xyzabc34 123456ab 234567bc 345678cd 9 | 456789de 567890ef 678901fg 789012gh 890123hi)) 10 | 11 | (defun init-aux (m n atoms) 12 | (declare (type fixnum m n)) 13 | (cond ((= m 0) (pop atoms)) 14 | (t (do ((i n (the fixnum (- i 2))) 15 | (a ())) 16 | ((< i 1) a) 17 | (declare (type fixnum i)) 18 | (push (pop atoms) a) 19 | (push (init-aux (the fixnum (1- m)) n atoms) a))))) 20 | 21 | (defun fprint-init (m n atoms) 22 | (let ((atoms (subst () () atoms))) 23 | (do ((a atoms (cdr a))) 24 | ((null (cdr a)) (rplacd a atoms))) 25 | (init-aux m n atoms))) 26 | 27 | (defvar test-pattern (fprint-init 6. 6. test-atoms)) 28 | 29 | (defun fprint () 30 | (if (probe-file "/tmp/fprint.tst") 31 | (delete-file "/tmp/fprint.tst")) 32 | (let ((stream (open "/tmp/fprint.tst" :direction :output))) 33 | (print test-pattern stream) 34 | (close stream))) 35 | 36 | (defun testfprint () 37 | (print (time (fprint)))) 38 | -------------------------------------------------------------------------------- /contrib/gabriel/fread.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/fread.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; FREAD -- Benchmark to read from a file. 5 | ;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created 6 | ;;; by FPRINT. 7 | 8 | (defun fread () 9 | (let ((stream (open "/tmp/fprint.tst" :direction :input))) 10 | (read stream) 11 | (close stream))) 12 | 13 | (defun testfread () 14 | (print (time (fread)))) 15 | -------------------------------------------------------------------------------- /contrib/gabriel/frpoly-mod.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/frpoly-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. 5 | ;; Originally writen in Franz Lisp by Richard Fateman. 6 | 7 | ;; PDIFFER1 appears in the code, but is not defined; is not called for in this 8 | ;; test, however. 9 | 10 | ;; 11 | ;; This contain 2 fixes from Gabriel's book. 12 | ;; 13 | ;; "ptimes3": after label 'b', change the "if" to a "cond". 14 | ;; The "go" should be activated when the condition 15 | ;; holds, NOT when it fails. 16 | ;; 17 | ;; The variables *x*, u*, and v are used specially, since this is 18 | ;; used to handle polynomial coefficients in a recursive 19 | ;; way. Declaring them global is the wrong approach. 20 | 21 | (defvar ans) 22 | (defvar coef) 23 | (defvar f) 24 | (defvar inc) 25 | (defvar i) 26 | (defvar qq) 27 | (defvar ss) 28 | (defvar v) 29 | (defvar *x*) 30 | (defvar *alpha*) 31 | (defvar *a*) 32 | (defvar *b*) 33 | (defvar *chk) 34 | (defvar *l) 35 | (defvar *p) 36 | (defvar q*) 37 | (defvar u*) 38 | (defvar *var) 39 | (defvar *y*) 40 | (defvar r) 41 | (defvar r2) 42 | (defvar r3) 43 | (defvar start) 44 | (defvar res1) 45 | (defvar res2) 46 | (defvar res3) 47 | 48 | ;(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) 49 | (defmacro valget (x) `(the fixnum (symbol-value ,x))) 50 | (defmacro pointergp (x y) `(> (valget ,x) (valget ,y))) 51 | (defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) 52 | (defmacro f> (x y) `(> (the fixnum ,x) (the fixnum ,y))) 53 | 54 | (defmacro pcoefp (e) `(atom ,e)) 55 | 56 | (defmacro pzerop (x) 57 | `(and (not (consp ,x)) 58 | (if (typep ,x 'fixnum) (eql 0 (the fixnum ,x)) 59 | (if (typep ,x 'float) (= 0.0 (the float ,x)))))) 60 | 61 | (defmacro pzero () 0) 62 | (defmacro cplus (x y) `(+ ,x ,y)) 63 | (defmacro ctimes (x y) `(* ,x ,y)) 64 | 65 | (defun pcoefadd (e c x) 66 | (if (pzerop c) 67 | x 68 | (cons e (cons c x)))) 69 | 70 | (defun pcplus (c p) 71 | (if (pcoefp p) 72 | (cplus p c) 73 | (psimp (car p) (pcplus1 c (cdr p))))) 74 | 75 | (defun pcplus1 (c x) 76 | (cond ((null x) 77 | (if (pzerop c) 78 | nil 79 | (cons 0 (cons c nil)))) 80 | ((pzerop (car x)) 81 | (pcoefadd 0 (pplus c (cadr x)) nil)) 82 | (t 83 | (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) 84 | 85 | (defun pctimes (c p) 86 | (if (pcoefp p) 87 | (ctimes c p) 88 | (psimp (car p) (pctimes1 c (cdr p))))) 89 | 90 | (defun pctimes1 (c x) 91 | (if (null x) 92 | nil 93 | (pcoefadd (car x) 94 | (ptimes c (cadr x)) 95 | (pctimes1 c (cddr x))))) 96 | 97 | (defun pplus (x y) 98 | (cond ((pcoefp x) 99 | (pcplus x y)) 100 | ((pcoefp y) 101 | (pcplus y x)) 102 | ((eq (car x) (car y)) 103 | (psimp (car x) (pplus1 (cdr y) (cdr x)))) 104 | ((pointergp (car x) (car y)) 105 | (psimp (car x) (pcplus1 y (cdr x)))) 106 | (t 107 | (psimp (car y) (pcplus1 x (cdr y)))))) 108 | 109 | (defun pplus1 (x y) 110 | (cond ((null x) y) 111 | ((null y) x) 112 | ((= (car x) (car y)) 113 | (pcoefadd (car x) 114 | (pplus (cadr x) (cadr y)) 115 | (pplus1 (cddr x) (cddr y)))) 116 | ((> (car x) (car y)) 117 | (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) 118 | (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) 119 | 120 | (defun psimp (var x) 121 | (cond ((null x) 0) 122 | ((atom x) x) 123 | ((zerop (car x)) 124 | (cadr x)) 125 | (t 126 | (cons var x)))) 127 | 128 | (defun ptimes (x y) 129 | (cond ((or (pzerop x) (pzerop y)) 130 | (pzero)) 131 | ((pcoefp x) 132 | (pctimes x y)) 133 | ((pcoefp y) 134 | (pctimes y x)) 135 | ((eq (car x) (car y)) 136 | (psimp (car x) (ptimes1 (cdr x) (cdr y)))) 137 | ((pointergp (car x) (car y)) 138 | (psimp (car x) (pctimes1 y (cdr x)))) 139 | (t 140 | (psimp (car y) (pctimes1 x (cdr y)))))) 141 | 142 | (defun ptimes1 (*x* y) 143 | (prog (u* v) 144 | (setq v (setq u* (ptimes2 y))) 145 | a 146 | (setq *x* (cddr *x*)) 147 | (if (null *x*) 148 | (return u*)) 149 | (ptimes3 y) 150 | (go a))) 151 | 152 | (defun ptimes2 (y) 153 | (if (null y) 154 | nil 155 | (pcoefadd (+ (car *x*) (car y)) 156 | (ptimes (cadr *x*) (cadr y)) 157 | (ptimes2 (cddr y))))) 158 | 159 | (defun ptimes3 (y) 160 | (prog (e u c) 161 | a1 (if (null y) 162 | (return nil)) 163 | (setq e (f+ (car *x*) (car y)) 164 | c (ptimes (cadr y) (cadr *x*) )) 165 | (cond ((pzerop c) 166 | (setq y (cddr y)) 167 | (go a1)) 168 | ((or (null v) (f> e (car v))) 169 | (setq u* (setq v (pplus1 u* (list e c)))) 170 | (setq y (cddr y)) 171 | (go a1)) 172 | ((= e (car v)) 173 | (setq c (pplus c (cadr v))) 174 | (if (pzerop c) ; never true, evidently 175 | (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))) 176 | (rplaca (cdr v) c)) 177 | (setq y (cddr y)) 178 | (go a1))) 179 | a (cond ((and (cddr v) (> (caddr v) e)) 180 | (setq v (cddr v)) 181 | (go a))) 182 | (setq u (cdr v)) 183 | b (cond ((or (null (cdr u)) (< (cadr u) e)) 184 | (rplacd u (cons e (cons c (cdr u)))) (go e))) 185 | (cond ((pzerop (setq c (pplus (caddr u) c))) 186 | (rplacd u (cdddr u)) 187 | (go d)) 188 | (t 189 | (rplaca (cddr u) c))) 190 | e (setq u (cddr u)) 191 | d (setq y (cddr y)) 192 | (if (null y) 193 | (return nil)) 194 | (setq e (f+ (car *x*) (car y)) 195 | c (ptimes (cadr y) (cadr *x*))) 196 | c (cond ((and (cdr u) (> (cadr u) e)) 197 | (setq u (cddr u)) 198 | (go c))) 199 | (go b))) 200 | 201 | (defun pexptsq (p n) 202 | (do ((n (floor n 2) (floor n 2)) 203 | (s (if (oddp n) p 1))) 204 | ((zerop n) s) 205 | (setq p (ptimes p p)) 206 | (and (oddp n) (setq s (ptimes s p))))) 207 | 208 | (eval-when (load eval) 209 | (setf (valget 'x ) 1) 210 | (setf (valget 'y) 2) 211 | (setf (valget 'z ) 3) 212 | (setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))) ; r= x+y+z+1 213 | r2 (ptimes r 100000) ; r2 = 100000*r 214 | r3 (ptimes r 1.0))) ; r3 = r with floating point coefficients 215 | 216 | 217 | (defun standard-frpoly-test1 () 218 | (progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil)) 219 | 220 | (defun standard-frpoly-test2 () 221 | (progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil)) 222 | 223 | (defun standard-frpoly-test3 () 224 | (progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil)) 225 | 226 | (defun standard-frpoly-test4 () 227 | (progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil)) 228 | 229 | (defun testfrpoly () 230 | (testfrpoly-1) 231 | (testfrpoly-2) 232 | (testfrpoly-3) 233 | (testfrpoly-4)) 234 | 235 | (defun testfrpoly-1 () 236 | (print (time (standard-frpoly-test1)))) 237 | 238 | (defun testfrpoly-2 () 239 | (print (time (standard-frpoly-test2)))) 240 | 241 | (defun testfrpoly-3 () 242 | (print (time (standard-frpoly-test3)))) 243 | 244 | (defun testfrpoly-4 () 245 | (print (time (standard-frpoly-test4)))) 246 | -------------------------------------------------------------------------------- /contrib/gabriel/frpoly.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/frpoly.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. 5 | ;; Originally writen in Franz Lisp by Richard Fateman. 6 | 7 | ;; PDIFFER1 appears in the code, but is not defined; is not called for in this 8 | ;; test, however. 9 | 10 | ;; 11 | ;; This contain 2 fixes from Gabriel's book. 12 | ;; 13 | ;; "ptimes3": after label 'b', change the "if" to a "cond". 14 | ;; The "go" should be activated when the condition 15 | ;; holds, NOT when it fails. 16 | ;; 17 | ;; The variables *x*, u*, and v are used specially, since this is 18 | ;; used to handle polynomial coefficients in a recursive 19 | ;; way. Declaring them global is the wrong approach. 20 | 21 | (defvar ans) 22 | (defvar coef) 23 | (defvar f) 24 | (defvar inc) 25 | (defvar i) 26 | (defvar qq) 27 | (defvar ss) 28 | (defvar v) 29 | (defvar *x*) 30 | (defvar *alpha*) 31 | (defvar *a*) 32 | (defvar *b*) 33 | (defvar *chk) 34 | (defvar *l) 35 | (defvar *p) 36 | (defvar q*) 37 | (defvar u*) 38 | (defvar *var) 39 | (defvar *y*) 40 | (defvar r) 41 | (defvar r2) 42 | (defvar r3) 43 | (defvar start) 44 | (defvar res1) 45 | (defvar res2) 46 | (defvar res3) 47 | 48 | (defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) 49 | (defmacro pcoefp (e) `(atom ,e)) 50 | 51 | (defmacro pzerop (x) 52 | `(if (numberp ,x) ; no signp in CL 53 | (zerop ,x))) 54 | (defmacro pzero () 0) 55 | (defmacro cplus (x y) `(+ ,x ,y)) 56 | (defmacro ctimes (x y) `(* ,x ,y)) 57 | 58 | (defun pcoefadd (e c x) 59 | (if (pzerop c) 60 | x 61 | (cons e (cons c x)))) 62 | 63 | (defun pcplus (c p) 64 | (if (pcoefp p) 65 | (cplus p c) 66 | (psimp (car p) (pcplus1 c (cdr p))))) 67 | 68 | (defun pcplus1 (c x) 69 | (cond ((null x) 70 | (if (pzerop c) 71 | nil 72 | (cons 0 (cons c nil)))) 73 | ((pzerop (car x)) 74 | (pcoefadd 0 (pplus c (cadr x)) nil)) 75 | (t 76 | (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) 77 | 78 | (defun pctimes (c p) 79 | (if (pcoefp p) 80 | (ctimes c p) 81 | (psimp (car p) (pctimes1 c (cdr p))))) 82 | 83 | (defun pctimes1 (c x) 84 | (if (null x) 85 | nil 86 | (pcoefadd (car x) 87 | (ptimes c (cadr x)) 88 | (pctimes1 c (cddr x))))) 89 | 90 | (defun pplus (x y) 91 | (cond ((pcoefp x) 92 | (pcplus x y)) 93 | ((pcoefp y) 94 | (pcplus y x)) 95 | ((eq (car x) (car y)) 96 | (psimp (car x) (pplus1 (cdr y) (cdr x)))) 97 | ((pointergp (car x) (car y)) 98 | (psimp (car x) (pcplus1 y (cdr x)))) 99 | (t 100 | (psimp (car y) (pcplus1 x (cdr y)))))) 101 | 102 | (defun pplus1 (x y) 103 | (cond ((null x) y) 104 | ((null y) x) 105 | ((= (car x) (car y)) 106 | (pcoefadd (car x) 107 | (pplus (cadr x) (cadr y)) 108 | (pplus1 (cddr x) (cddr y)))) 109 | ((> (car x) (car y)) 110 | (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) 111 | (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) 112 | 113 | (defun psimp (var x) 114 | (cond ((null x) 0) 115 | ((atom x) x) 116 | ((zerop (car x)) 117 | (cadr x)) 118 | (t 119 | (cons var x)))) 120 | 121 | (defun ptimes (x y) 122 | (cond ((or (pzerop x) (pzerop y)) 123 | (pzero)) 124 | ((pcoefp x) 125 | (pctimes x y)) 126 | ((pcoefp y) 127 | (pctimes y x)) 128 | ((eq (car x) (car y)) 129 | (psimp (car x) (ptimes1 (cdr x) (cdr y)))) 130 | ((pointergp (car x) (car y)) 131 | (psimp (car x) (pctimes1 y (cdr x)))) 132 | (t 133 | (psimp (car y) (pctimes1 x (cdr y)))))) 134 | 135 | (defun ptimes1 (*x* y) 136 | (prog (u* v) 137 | (setq v (setq u* (ptimes2 y))) 138 | a 139 | (setq *x* (cddr *x*)) 140 | (if (null *x*) 141 | (return u*)) 142 | (ptimes3 y) 143 | (go a))) 144 | 145 | (defun ptimes2 (y) 146 | (if (null y) 147 | nil 148 | (pcoefadd (+ (car *x*) (car y)) 149 | (ptimes (cadr *x*) (cadr y)) 150 | (ptimes2 (cddr y))))) 151 | 152 | (defun ptimes3 (y) 153 | (prog (e u c) 154 | a1 (if (null y) 155 | (return nil)) 156 | (setq e (+ (car *x*) (car y)) 157 | c (ptimes (cadr y) (cadr *x*) )) 158 | (cond ((pzerop c) 159 | (setq y (cddr y)) 160 | (go a1)) 161 | ((or (null v) (> e (car v))) 162 | (setq u* (setq v (pplus1 u* (list e c)))) 163 | (setq y (cddr y)) 164 | (go a1)) 165 | ((= e (car v)) 166 | (setq c (pplus c (cadr v))) 167 | (if (pzerop c) ; never true, evidently 168 | (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))) 169 | (rplaca (cdr v) c)) 170 | (setq y (cddr y)) 171 | (go a1))) 172 | a (cond ((and (cddr v) (> (caddr v) e)) 173 | (setq v (cddr v)) 174 | (go a))) 175 | (setq u (cdr v)) 176 | b (cond ((or (null (cdr u)) (< (cadr u) e)) 177 | (rplacd u (cons e (cons c (cdr u)))) (go e))) 178 | (cond ((pzerop (setq c (pplus (caddr u) c))) 179 | (rplacd u (cdddr u)) 180 | (go d)) 181 | (t 182 | (rplaca (cddr u) c))) 183 | e (setq u (cddr u)) 184 | d (setq y (cddr y)) 185 | (if (null y) 186 | (return nil)) 187 | (setq e (+ (car *x*) (car y)) 188 | c (ptimes (cadr y) (cadr *x*))) 189 | c (cond ((and (cdr u) (> (cadr u) e)) 190 | (setq u (cddr u)) 191 | (go c))) 192 | (go b))) 193 | 194 | (defun pexptsq (p n) 195 | (do ((n (floor n 2) (floor n 2)) 196 | (s (if (oddp n) p 1))) 197 | ((zerop n) s) 198 | (setq p (ptimes p p)) 199 | (and (oddp n) (setq s (ptimes s p))))) 200 | 201 | (eval-when (load eval) 202 | (setf (get 'x 'order) 1) 203 | (setf (get 'y 'order) 2) 204 | (setf (get 'z 'order) 3) 205 | (setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))) ; r= x+y+z+1 206 | r2 (ptimes r 100000) ; r2 = 100000*r 207 | r3 (ptimes r 1.0))) ; r3 = r with floating point coefficients 208 | 209 | 210 | (defun standard-frpoly-test1 () 211 | (progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil)) 212 | 213 | (defun standard-frpoly-test2 () 214 | (progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil)) 215 | 216 | (defun standard-frpoly-test3 () 217 | (progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil)) 218 | 219 | (defun standard-frpoly-test4 () 220 | (progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil)) 221 | 222 | (defun testfrpoly () 223 | (testfrpoly-1) 224 | (testfrpoly-2) 225 | (testfrpoly-3) 226 | (testfrpoly-4)) 227 | 228 | (defun testfrpoly-1 () 229 | (print (time (standard-frpoly-test1)))) 230 | 231 | (defun testfrpoly-2 () 232 | (print (time (standard-frpoly-test2)))) 233 | 234 | (defun testfrpoly-3 () 235 | (print (time (standard-frpoly-test3)))) 236 | 237 | (defun testfrpoly-4 () 238 | (print (time (standard-frpoly-test4)))) 239 | -------------------------------------------------------------------------------- /contrib/gabriel/integer.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defun pi-inv (bits &aux (m 0)) 3 | (declare (type integer bits m)) 4 | (let* ((n (+ bits (integer-length bits) 11)) 5 | (tt (truncate (ash 1 n) 882)) 6 | (d (* 4 882 882)) 7 | (s 0)) 8 | (declare (type integer s d tt n)) 9 | ; (print (list n tt d s)) 10 | (do ((i 2 (+ i 2)) 11 | (j 1123 (+ j 21460))) 12 | ((zerop tt) (cons s (- (+ n 2)))) 13 | (declare (type integer i j)) 14 | (setq s (+ s (* j tt)) 15 | m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) 16 | tt (truncate (* m tt) (* d (the integer (expt i 3)))))))) 17 | 18 | (defun dvide (x y n) 19 | (let* ((ew (+ (integer-length (car y)) (- (integer-length (car x))) n 1)) 20 | (mw (truncate (ash (car x) ew) (car y))) 21 | (ew (- (cdr x) (cdr y) ew))) 22 | (cons mw ew))) 23 | 24 | (defun pi (bits) (dvide (cons 1 0) (pi-inv bits) bits)) 25 | 26 | (defun test-float (x) (scale-float (coerce (car x) 'long-float) (cdr x))) 27 | 28 | (defun factorial (n) 29 | (declare (type fixnum n)) 30 | (do ((i 1 (+ i 1)) 31 | (ans 1 (* i ans))) 32 | ((> i n) ans) 33 | (declare (type fixnum i) (type integer ans)))) 34 | 35 | -------------------------------------------------------------------------------- /contrib/gabriel/make-declare.lsp: -------------------------------------------------------------------------------- 1 | ;; By W. Schelter 2 | ;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp") 3 | 4 | ;; Was 'si, but I changed it to :user. Scott D. Anderson, 2/28/95 5 | (in-package :user) 6 | 7 | ;; You may wish to adjust the following to output the proclamations 8 | ;; for inclusion in a file. All fixed arg functions should be proclaimed 9 | ;; before their references for maximum efficiency. 10 | 11 | ;; CAVEAT: The following code only checks for fixed args, it does 12 | ;; not check for single valuedness BUT does make a proclamation 13 | ;; to that efect. Unfortunately it is impossible to tell about 14 | ;; multiple values without doing a full compiler type pass over 15 | ;; all files in the relevant system. However the AKCL compiler should 16 | ;; warn if you inadvertantly proclaim foo to be single valued and then try 17 | ;; to use more than one value. 18 | 19 | (DEFVAR *DECLARE-T-ONLY* NIL) 20 | (DEFUN PROCLAIM-FILE (NAME &OPTIONAL *DECLARE-T-ONLY*) 21 | (WITH-OPEN-FILE 22 | (FILE NAME 23 | :DIRECTION :INPUT) 24 | (LET ((EOF (CONS NIL NIL))) 25 | (LOOP 26 | (LET ((FORM (READ FILE NIL EOF))) 27 | (COND ((EQ EOF FORM) (RETURN NIL)) 28 | ((MAKE-DECLARE-FORM FORM )))))))) 29 | 30 | (DEFUN MAKE-DECLARE-FORM (FORM) 31 | ; !!! 32 | (WHEN 33 | (LISTP FORM) 34 | (COND ((MEMBER (CAR FORM) '(EVAL-WHEN )) 35 | (DOLIST (V (CDDR FORM)) (MAKE-DECLARE-FORM V))) 36 | ((MEMBER (CAR FORM) '(PROGN )) 37 | (DOLIST (V (CDR FORM)) (MAKE-DECLARE-FORM V))) 38 | ((MEMBER (CAR FORM) '(IN-PACKAGE DEFCONSTANT)) 39 | (EVAL FORM)) 40 | ((MEMBER (CAR FORM) '(DEFUN)) 41 | (COND 42 | ((AND 43 | (CONSP (CADDR FORM)) 44 | (NOT (MEMBER '&REST (CADDR FORM))) 45 | (NOT (MEMBER '&BODY (CADDR FORM))) 46 | (NOT (MEMBER '&KEY (CADDR FORM))) 47 | (NOT (MEMBER '&OPTIONAL (CADDR FORM)))) 48 | ;;could print declarations here. 49 | (print (list (cadr form) (ARG-DECLARES (THIRD FORM) (cdddr FORM)))) 50 | ;; The following in not legal Common Lisp syntax. Scott D. Anderson 3/1/95 51 | #+old 52 | (FUNCALL 'PROCLAIM 53 | (LIST 'FUNCTION 54 | (CADR FORM) 55 | (ARG-DECLARES (THIRD FORM) (cdddr FORM)) 56 | T)) 57 | ;; The following is my substitution. Scott D. Anderson 3/1/95 58 | (funcall 'proclaim 59 | `(ftype (function ,(arg-declares (third form) (cdddr form)) t) 60 | ,(cadr form))))))))) 61 | 62 | (DEFUN ARG-DECLARES (ARGS DECLS &AUX ANS) 63 | (COND ((STRINGP (CAR DECLS)) (SETQ DECLS (CADR DECLS))) 64 | (T (SETQ DECLS (CAR DECLS)))) 65 | (COND ((AND (not *declare-t-only*) 66 | (CONSP DECLS) (EQ (CAR DECLS ) 'DECLARE)) 67 | (DO ((V ARGS (CDR V))) 68 | ((OR (EQ (CAR V) '&AUX) 69 | (NULL V)) 70 | (NREVERSE ANS)) 71 | (PUSH (DECL-TYPE (CAR V) DECLS) ANS))) 72 | (T (MAKE-LIST (- (LENGTH args) 73 | (LENGTH (MEMBER '&AUX args))) 74 | :INITIAL-ELEMENT T)))) 75 | 76 | (DEFUN DECL-TYPE (V DECLS) 77 | (DOLIST (D (CDR DECLS)) 78 | (CASE (CAR D) 79 | (TYPE (IF (MEMBER V (CDDR D)) 80 | (RETURN-FROM DECL-TYPE (SECOND D)))) 81 | ((FIXNUM CHARACTER FLOAT LONG-FLOAT SHORT-FLOAT ) 82 | (IF (MEMBER V (CDR D)) (RETURN-FROM DECL-TYPE (CAR D)))))) 83 | T) 84 | 85 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle-mod-noproclaim.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle-mod-noproclaim.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (defconstant puzzle-size 511.) 6 | (defconstant puzzle-classmax 3.) 7 | (defconstant puzzle-typemax 12.)) 8 | 9 | (defvar **iii** 0) 10 | (defvar **kount** 0) 11 | (defvar puzzle-d 8.) 12 | '(proclaim '(type fixnum **iii** **kount** puzzle-d)) 13 | 14 | (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) 15 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 16 | (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 17 | (defvar puzzle (make-array (1+ puzzle-size))) 18 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 19 | 20 | '(proclaim '(type (array fixnum) piececount puzzle-class piecemax)) 21 | (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) 22 | 23 | 24 | '(proclaim '(type simple-vector puzzle)) 25 | 26 | '(proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 27 | puzzle-p)) 28 | 29 | (defun fit (i j) 30 | (declare (type fixnum i j)) 31 | (let ((end (fref piecemax i))) 32 | (declare (type fixnum end)) 33 | (do ((k 0 (the fixnum (1+ k)))) 34 | ((> k end) t) 35 | (declare (type fixnum k)) 36 | (cond ((aref puzzle-p i k) 37 | (cond ((aref puzzle (the fixnum (+ j k))) 38 | (return nil)))))))) 39 | 40 | '(proclaim '(function place (fixnum fixnum ) fixnum)) 41 | (defun jil () 3) 42 | (defun place (i j) 43 | (declare (type fixnum i j)) 44 | (let ((end (fref piecemax i))) 45 | (declare (type fixnum end)) 46 | (do ((k 0 (the fixnum (1+ k)))) 47 | ((> k end)) 48 | (declare (type fixnum k)) 49 | (cond ((aref puzzle-p i k) 50 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 51 | (setf (fref piececount (fref puzzle-class i)) 52 | (the fixnum 53 | (- (the fixnum 54 | (fref piececount (fref puzzle-class i))) 1))) 55 | (do ((k j (the fixnum (1+ k)))) 56 | ((> k puzzle-size) 57 | (terpri) 58 | (princ "Puzzle filled") 59 | 0) 60 | (declare (type fixnum k)) 61 | (cond ((not (aref puzzle k)) 62 | (return k)))))) 63 | 64 | (defun puzzle-remove (i j) 65 | (declare (type fixnum i j)) 66 | (let ((end (fref piecemax i))) 67 | (declare (type fixnum end)) 68 | (do ((k 0 (the fixnum (1+ k)))) 69 | ((> k end)) 70 | (declare (type fixnum k)) 71 | (cond ((aref puzzle-p i k) 72 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 73 | (setf (fref piececount (fref puzzle-class i)) 74 | (the fixnum 75 | (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) 76 | 77 | (defun trial (j) 78 | (declare (type fixnum j)) 79 | (let ((k 0)) 80 | (declare (type fixnum k)) 81 | (do ((i 0 (the fixnum (1+ i)))) 82 | ((> i puzzle-typemax) 83 | (setq **kount** (the fixnum (1+ **kount**))) nil) 84 | (declare (type fixnum i)) 85 | (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) 86 | (cond ((fit i j) 87 | (setq k (place i j)) 88 | (cond ((or (trial k) 89 | (= k 0)) 90 | (setq **kount** (the fixnum (+ **kount** 1))) 91 | (return t)) 92 | (t (puzzle-remove i j)))))))))) 93 | 94 | (defun definepiece (iclass ii jj kk) 95 | (declare (type fixnum ii jj kk)) 96 | (let ((index 0)) 97 | (declare (type fixnum index)) 98 | (do ((i 0 (the fixnum (1+ i)))) 99 | ((> i ii)) 100 | (declare (type fixnum i)) 101 | (do ((j 0 (the fixnum (1+ j)))) 102 | ((> j jj)) 103 | (declare (type fixnum j)) 104 | (do ((k 0 (the fixnum (1+ k)))) 105 | ((> k kk)) 106 | (declare (type fixnum k)) 107 | (setq index 108 | (+ i 109 | (the fixnum 110 | (* puzzle-d 111 | (the fixnum 112 | (+ j 113 | (the fixnum 114 | (* puzzle-d k)))))))) 115 | (setf (aref puzzle-p **iii** index) t)))) 116 | (setf (fref puzzle-class **iii**) iclass) 117 | (setf (fref piecemax **iii**) index) 118 | (cond ((not (= **iii** puzzle-typemax)) 119 | (setq **iii** (the fixnum (+ **iii** 1))))))) 120 | 121 | (defun puzzle-start () 122 | (do ((m 0 (the fixnum (1+ m)))) 123 | ((> m puzzle-size)) 124 | (declare (type fixnum m)) 125 | (setf (aref puzzle m) t)) 126 | (do ((i 1 (the fixnum (1+ i)))) 127 | ((> i 5)) 128 | (declare (type fixnum i)) 129 | (do ((j 1 (the fixnum (1+ j)))) 130 | ((> j 5)) 131 | (declare (type fixnum j)) 132 | (do ((k 1 (the fixnum (1+ k)))) 133 | ((> k 5)) 134 | (declare (type fixnum k)) 135 | (setf (aref puzzle 136 | (+ i 137 | (the fixnum 138 | (* puzzle-d 139 | (the fixnum 140 | (+ j 141 | (the fixnum 142 | (* puzzle-d k)))))))) 143 | nil)))) 144 | (do ((i 0 (the fixnum (1+ i)))) 145 | ((> i puzzle-typemax)) 146 | (declare (type fixnum i)) 147 | (do ((m 0 (the fixnum (1+ m)))) 148 | ((> m puzzle-size)) 149 | (declare (type fixnum m)) 150 | (setf (aref puzzle-p i m) nil))) 151 | (setq **iii** 0) 152 | (definepiece 0 3 1 0) 153 | (definepiece 0 1 0 3) 154 | (definepiece 0 0 3 1) 155 | (definepiece 0 1 3 0) 156 | (definepiece 0 3 0 1) 157 | (definepiece 0 0 1 3) 158 | 159 | (definepiece 1 2 0 0) 160 | (definepiece 1 0 2 0) 161 | (definepiece 1 0 0 2) 162 | 163 | (definepiece 2 1 1 0) 164 | (definepiece 2 1 0 1) 165 | (definepiece 2 0 1 1) 166 | 167 | (definepiece 3 1 1 1) 168 | 169 | (setf (fref piececount 0) 13.) 170 | (setf (fref piececount 1) 3) 171 | (setf (fref piececount 2) 1) 172 | (setf (fref piececount 3) 1) 173 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 174 | (n 0)(**kount** 0)) 175 | (declare (type fixnum m n **kount**)) 176 | (cond ((fit 0 m) (setq n (place 0 m))) 177 | (t (format t "~%Error."))) 178 | (cond ((trial n) 179 | (format t "~%Success in ~4D trials." **kount**)) 180 | (t (format t "~%Failure."))))) 181 | 182 | (defun testpuzzle () 183 | (time (puzzle-start))) 184 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle-mod.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (cl:spy *package*) ; SDA 6 | (defconstant puzzle-size 511.) 7 | (defconstant puzzle-classmax 3.) 8 | (defconstant puzzle-typemax 12.)) 9 | 10 | (defvar **iii** 0) 11 | (defvar **kount** 0) 12 | (defvar puzzle-d 8.) 13 | (proclaim '(type fixnum **iii** **kount** puzzle-d)) 14 | 15 | (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) 16 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 17 | (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 18 | (defvar puzzle (make-array (1+ puzzle-size))) 19 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 20 | 21 | (proclaim '(type (array fixnum) piececount puzzle-class piecemax)) 22 | (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) 23 | 24 | 25 | (proclaim '(type simple-vector puzzle)) 26 | 27 | (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 28 | puzzle-p)) 29 | 30 | (defun fit (i j) 31 | (declare (type fixnum i j)) 32 | (let ((end (fref piecemax i))) 33 | (declare (type fixnum end)) 34 | (do ((k 0 (the fixnum (1+ k)))) 35 | ((> k end) t) 36 | (declare (type fixnum k)) 37 | (cond ((aref puzzle-p i k) 38 | (cond ((aref puzzle (the fixnum (+ j k))) 39 | (return nil)))))))) 40 | 41 | (proclaim '(function place (fixnum fixnum ) fixnum)) 42 | (defun jil () 3) 43 | (defun place (i j) 44 | (declare (type fixnum i j)) 45 | (let ((end (fref piecemax i))) 46 | (declare (type fixnum end)) 47 | (do ((k 0 (the fixnum (1+ k)))) 48 | ((> k end)) 49 | (declare (type fixnum k)) 50 | (cond ((aref puzzle-p i k) 51 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 52 | (setf (fref piececount (fref puzzle-class i)) 53 | (the fixnum 54 | (- (the fixnum 55 | (fref piececount (fref puzzle-class i))) 1))) 56 | (do ((k j (the fixnum (1+ k)))) 57 | ((> k puzzle-size) 58 | (terpri) 59 | (princ "Puzzle filled") 60 | 0) 61 | (declare (type fixnum k)) 62 | (cond ((not (aref puzzle k)) 63 | (return k)))))) 64 | 65 | ;; SDA 66 | (eval-when (:compile-toplevel) 67 | (cl:spy (macroexpand '(fref piececount (fref puzzle-class i))))) 68 | 69 | ;; SDA 70 | (defun test-fn1 (i) 71 | (declare (type fixnum i)) 72 | (setf (fref piececount (fref puzzle-class i)) 73 | (the fixnum 74 | (+ (the fixnum (fref piececount (fref puzzle-class i))) 1)))) 75 | 76 | ;; SDA 77 | (defun test-fn2 (i) 78 | (declare (type fixnum i)) 79 | (setf (the fixnum (aref piececount (the fixnum (aref puzzle-class i)))) 80 | (the fixnum 81 | (+ (the fixnum (the fixnum (aref piececount (the fixnum (aref puzzle-class i))))) 1)))) 82 | 83 | ;; SDA 84 | (defun test-fn3 (i) 85 | (declare (type fixnum i)) 86 | (setf (the fixnum (aref piececount (the fixnum i))) 87 | (the fixnum 88 | (+ (the fixnum i) 1)))) 89 | 90 | ;; SDA 91 | (defun test-fn4 (i) 92 | (declare (type fixnum i)) 93 | (setf (the fixnum (aref piececount i)) 94 | (1+ i))) 95 | 96 | ;; SDA 97 | (defun test-fn5 (i) 98 | (declare (type fixnum i)) 99 | (setf (aref piececount i) 100 | (1+ i))) 101 | 102 | (cl:in-package :cl-user) 103 | 104 | ;; SDA 105 | (defun test-fn6 (i) 106 | (declare (type fixnum i)) 107 | (setf (aref piececount i) 108 | (1+ i))) 109 | 110 | (defun puzzle-remove (i j) 111 | (declare (type fixnum i j)) 112 | (let ((end (fref piecemax i))) 113 | (declare (type fixnum end)) 114 | (do ((k 0 (the fixnum (1+ k)))) 115 | ((> k end)) 116 | (declare (type fixnum k)) 117 | (cond ((aref puzzle-p i k) 118 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 119 | (setf (fref piececount (fref puzzle-class i)) 120 | (the fixnum 121 | (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) 122 | 123 | (defun trial (j) 124 | (declare (type fixnum j)) 125 | (let ((k 0)) 126 | (declare (type fixnum k)) 127 | (do ((i 0 (the fixnum (1+ i)))) 128 | ((> i puzzle-typemax) 129 | (setq **kount** (the fixnum (1+ **kount**))) nil) 130 | (declare (type fixnum i)) 131 | (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) 132 | (cond ((fit i j) 133 | (setq k (place i j)) 134 | (cond ((or (trial k) 135 | (= k 0)) 136 | (setq **kount** (the fixnum (+ **kount** 1))) 137 | (return t)) 138 | (t (puzzle-remove i j)))))))))) 139 | 140 | (defun definepiece (iclass ii jj kk) 141 | (declare (type fixnum ii jj kk)) 142 | (let ((index 0)) 143 | (declare (type fixnum index)) 144 | (do ((i 0 (the fixnum (1+ i)))) 145 | ((> i ii)) 146 | (declare (type fixnum i)) 147 | (do ((j 0 (the fixnum (1+ j)))) 148 | ((> j jj)) 149 | (declare (type fixnum j)) 150 | (do ((k 0 (the fixnum (1+ k)))) 151 | ((> k kk)) 152 | (declare (type fixnum k)) 153 | (setq index 154 | (+ i 155 | (the fixnum 156 | (* puzzle-d 157 | (the fixnum 158 | (+ j 159 | (the fixnum 160 | (* puzzle-d k)))))))) 161 | (setf (aref puzzle-p **iii** index) t)))) 162 | (setf (fref puzzle-class **iii**) iclass) 163 | (setf (fref piecemax **iii**) index) 164 | (cond ((not (= **iii** puzzle-typemax)) 165 | (setq **iii** (the fixnum (+ **iii** 1))))))) 166 | 167 | (defun puzzle-start () 168 | (do ((m 0 (the fixnum (1+ m)))) 169 | ((> m puzzle-size)) 170 | (declare (type fixnum m)) 171 | (setf (aref puzzle m) t)) 172 | (do ((i 1 (the fixnum (1+ i)))) 173 | ((> i 5)) 174 | (declare (type fixnum i)) 175 | (do ((j 1 (the fixnum (1+ j)))) 176 | ((> j 5)) 177 | (declare (type fixnum j)) 178 | (do ((k 1 (the fixnum (1+ k)))) 179 | ((> k 5)) 180 | (declare (type fixnum k)) 181 | (setf (aref puzzle 182 | (+ i 183 | (the fixnum 184 | (* puzzle-d 185 | (the fixnum 186 | (+ j 187 | (the fixnum 188 | (* puzzle-d k)))))))) 189 | nil)))) 190 | (do ((i 0 (the fixnum (1+ i)))) 191 | ((> i puzzle-typemax)) 192 | (declare (type fixnum i)) 193 | (do ((m 0 (the fixnum (1+ m)))) 194 | ((> m puzzle-size)) 195 | (declare (type fixnum m)) 196 | (setf (aref puzzle-p i m) nil))) 197 | (setq **iii** 0) 198 | (definepiece 0 3 1 0) 199 | (definepiece 0 1 0 3) 200 | (definepiece 0 0 3 1) 201 | (definepiece 0 1 3 0) 202 | (definepiece 0 3 0 1) 203 | (definepiece 0 0 1 3) 204 | 205 | (definepiece 1 2 0 0) 206 | (definepiece 1 0 2 0) 207 | (definepiece 1 0 0 2) 208 | 209 | (definepiece 2 1 1 0) 210 | (definepiece 2 1 0 1) 211 | (definepiece 2 0 1 1) 212 | 213 | (definepiece 3 1 1 1) 214 | 215 | (setf (fref piececount 0) 13.) 216 | (setf (fref piececount 1) 3) 217 | (setf (fref piececount 2) 1) 218 | (setf (fref piececount 3) 1) 219 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 220 | (n 0)(**kount** 0)) 221 | (declare (type fixnum m n **kount**)) 222 | (cond ((fit 0 m) (setq n (place 0 m))) 223 | (t (format t "~%Error."))) 224 | (cond ((trial n) 225 | (format t "~%Success in ~4D trials." **kount**)) 226 | (t (format t "~%Failure."))))) 227 | 228 | (defun testpuzzle () 229 | (time (puzzle-start))) 230 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle-mod1.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle-mod1.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (defconstant puzzle-size 511.) 6 | (defconstant puzzle-classmax 3.) 7 | (defconstant puzzle-typemax 12.)) 8 | 9 | (defvar **iii** 0) 10 | (defvar **kount** 0) 11 | (defvar puzzle-d 8.) 12 | (proclaim '(type fixnum **iii** **kount** puzzle-d)) 13 | 14 | (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) 15 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 16 | (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 17 | (defvar puzzle (make-array (1+ puzzle-size))) 18 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 19 | 20 | (proclaim '(type (array fixnum) piececount puzzle-class piecemax)) 21 | (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) 22 | 23 | 24 | (proclaim '(type simple-vector puzzle)) 25 | 26 | (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 27 | puzzle-p)) 28 | 29 | (defun fit (i j) 30 | (declare (type fixnum i j)) 31 | (let ((end (fref piecemax i)) 32 | (puzzle-pl puzzle-p)) 33 | (declare (type fixnum end) 34 | (type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 35 | puzzle-pl) 36 | ) 37 | (do ((k 0 (the fixnum (1+ k)))) 38 | ((> k end) t) 39 | (declare (type fixnum k)) 40 | (cond ((aref puzzle-pl i k) 41 | (cond ((aref puzzle (the fixnum (+ j k))) 42 | (return nil)))))))) 43 | 44 | (proclaim '(function place (fixnum fixnum ) fixnum)) 45 | 46 | (defun place (i j) 47 | (declare (type fixnum i j)) 48 | (let ((end (fref piecemax i))) 49 | (declare (type fixnum end)) 50 | (do ((k 0 (the fixnum (1+ k)))) 51 | ((> k end)) 52 | (declare (type fixnum k)) 53 | (cond ((aref puzzle-p i k) 54 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 55 | (setf (fref piececount (fref puzzle-class i)) 56 | (the fixnum 57 | (- (the fixnum 58 | (fref piececount (fref puzzle-class i))) 1))) 59 | (do ((k j (the fixnum (1+ k)))) 60 | ((> k puzzle-size) 61 | (terpri) 62 | (princ "Puzzle filled") 63 | 0) 64 | (declare (type fixnum k)) 65 | (cond ((not (aref puzzle k)) 66 | (return k)))))) 67 | 68 | 69 | (defun puzzle-remove (i j) 70 | (declare (type fixnum i j)) 71 | (let ((end (fref piecemax i))) 72 | (declare (type fixnum end)) 73 | (do ((k 0 (the fixnum (1+ k)))) 74 | ((> k end)) 75 | (declare (type fixnum k)) 76 | (cond ((aref puzzle-p i k) 77 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 78 | (setf (fref piececount (fref puzzle-class i)) 79 | (the fixnum 80 | (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) 81 | 82 | (defun trial (j) 83 | (declare (type fixnum j)) 84 | (let ((k 0)) 85 | (declare (type fixnum k)) 86 | (do ((i 0 (the fixnum (1+ i)))) 87 | ((> i puzzle-typemax) 88 | (setq **kount** (the fixnum (1+ **kount**))) nil) 89 | (declare (type fixnum i)) 90 | (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) 91 | (cond ((fit i j) 92 | (setq k (place i j)) 93 | (cond ((or (trial k) 94 | (= k 0)) 95 | (setq **kount** (the fixnum (+ **kount** 1))) 96 | (return t)) 97 | (t (puzzle-remove i j)))))))))) 98 | 99 | (defun definepiece (iclass ii jj kk) 100 | (declare (type fixnum ii jj kk)) 101 | (let ((index 0)) 102 | (declare (type fixnum index)) 103 | (do ((i 0 (the fixnum (1+ i)))) 104 | ((> i ii)) 105 | (declare (type fixnum i)) 106 | (do ((j 0 (the fixnum (1+ j)))) 107 | ((> j jj)) 108 | (declare (type fixnum j)) 109 | (do ((k 0 (the fixnum (1+ k)))) 110 | ((> k kk)) 111 | (declare (type fixnum k)) 112 | (setq index 113 | (+ i 114 | (the fixnum 115 | (* puzzle-d 116 | (the fixnum 117 | (+ j 118 | (the fixnum 119 | (* puzzle-d k)))))))) 120 | (setf (aref puzzle-p **iii** index) t)))) 121 | (setf (fref puzzle-class **iii**) iclass) 122 | (setf (fref piecemax **iii**) index) 123 | (cond ((not (= **iii** puzzle-typemax)) 124 | (setq **iii** (the fixnum (+ **iii** 1))))))) 125 | 126 | (defun puzzle-start () 127 | (do ((m 0 (the fixnum (1+ m)))) 128 | ((> m puzzle-size)) 129 | (declare (type fixnum m)) 130 | (setf (aref puzzle m) t)) 131 | (do ((i 1 (the fixnum (1+ i)))) 132 | ((> i 5)) 133 | (declare (type fixnum i)) 134 | (do ((j 1 (the fixnum (1+ j)))) 135 | ((> j 5)) 136 | (declare (type fixnum j)) 137 | (do ((k 1 (the fixnum (1+ k)))) 138 | ((> k 5)) 139 | (declare (type fixnum k)) 140 | (setf (aref puzzle 141 | (+ i 142 | (the fixnum 143 | (* puzzle-d 144 | (the fixnum 145 | (+ j 146 | (the fixnum 147 | (* puzzle-d k)))))))) 148 | nil)))) 149 | (do ((i 0 (the fixnum (1+ i)))) 150 | ((> i puzzle-typemax)) 151 | (declare (type fixnum i)) 152 | (do ((m 0 (the fixnum (1+ m)))) 153 | ((> m puzzle-size)) 154 | (declare (type fixnum m)) 155 | (setf (aref puzzle-p i m) nil))) 156 | (setq **iii** 0) 157 | (definepiece 0 3 1 0) 158 | (definepiece 0 1 0 3) 159 | (definepiece 0 0 3 1) 160 | (definepiece 0 1 3 0) 161 | (definepiece 0 3 0 1) 162 | (definepiece 0 0 1 3) 163 | 164 | (definepiece 1 2 0 0) 165 | (definepiece 1 0 2 0) 166 | (definepiece 1 0 0 2) 167 | 168 | (definepiece 2 1 1 0) 169 | (definepiece 2 1 0 1) 170 | (definepiece 2 0 1 1) 171 | 172 | (definepiece 3 1 1 1) 173 | 174 | (setf (fref piececount 0) 13.) 175 | (setf (fref piececount 1) 3) 176 | (setf (fref piececount 2) 1) 177 | (setf (fref piececount 3) 1) 178 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 179 | (n 0)(**kount** 0)) 180 | (declare (type fixnum m n **kount**)) 181 | (cond ((fit 0 m) (setq n (place 0 m))) 182 | (t (format t "~%Error."))) 183 | (cond ((trial n) 184 | (format t "~%Success in ~4D trials." **kount**)) 185 | (t (format t "~%Failure."))))) 186 | 187 | (defun testpuzzle () 188 | (time (puzzle-start))) 189 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle-mod2.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle-mod2.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (defconstant puzzle-size 511.) 6 | (defconstant puzzle-classmax 3.) 7 | (defconstant puzzle-typemax 12.)) 8 | 9 | (defvar **iii** 0) 10 | (defvar **kount** 0) 11 | (defvar puzzle-d 8.) 12 | (proclaim '(type fixnum **iii** **kount** puzzle-d)) 13 | 14 | (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) 15 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 16 | (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 17 | (defvar puzzle (make-array (1+ puzzle-size))) 18 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 19 | 20 | (proclaim '(type (array fixnum) piececount puzzle-class piecemax)) 21 | (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) 22 | 23 | 24 | (proclaim '(type simple-vector puzzle)) 25 | 26 | (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 27 | puzzle-p)) 28 | 29 | (defun fit (i j) 30 | (declare (type fixnum i j)) 31 | (let ((end (aref piecemax i))) 32 | (declare (type fixnum end)) 33 | (do ((k 0 (the fixnum (1+ k)))) 34 | ((> k end) t) 35 | (declare (type fixnum k)) 36 | (cond ((aref puzzle-p i k) 37 | (cond ((aref puzzle (the fixnum (+ j k))) 38 | (return nil)))))))) 39 | 40 | (proclaim '(function place (fixnum fixnum ) fixnum)) 41 | (proclaim '(function puzzle-remove (fixnum fixnum) fixnum)) 42 | (defun jil () 3) 43 | (defun place (i j) 44 | (declare (type fixnum i j)) 45 | (let ((end (aref piecemax i))) 46 | (declare (type fixnum end)) 47 | (do ((k 0 (the fixnum (1+ k)))) 48 | ((> k end)) 49 | (declare (type fixnum k)) 50 | (cond ((aref puzzle-p i k) 51 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 52 | (setf (aref piececount (aref puzzle-class i)) 53 | (the fixnum 54 | (- (the fixnum 55 | (aref piececount (aref puzzle-class i))) 1))) 56 | (do ((k j (the fixnum (1+ k)))) 57 | ((> k puzzle-size) 58 | (terpri) 59 | (princ "Puzzle filled") 60 | 0) 61 | (declare (type fixnum k)) 62 | (cond ((not (aref puzzle k)) 63 | (return k)))))) 64 | 65 | 66 | (defun puzzle-remove (i j) 67 | (declare (type fixnum i j)) 68 | (let ((end (aref piecemax i))) 69 | (declare (type fixnum end)) 70 | (do ((k 0 (the fixnum (1+ k)))) 71 | ((> k end)) 72 | (declare (type fixnum k)) 73 | (cond ((aref puzzle-p i k) 74 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 75 | (setf (aref piececount (aref puzzle-class i)) 76 | (the fixnum 77 | (+ (the fixnum (aref piececount (aref puzzle-class i))) 1))))) 78 | 79 | (defun trial (j) 80 | (declare (type fixnum j)) 81 | (let ((k 0)) 82 | (declare (type fixnum k)) 83 | (do ((i 0 (the fixnum (1+ i)))) 84 | ((> i puzzle-typemax) 85 | (setq **kount** (the fixnum (1+ **kount**))) nil) 86 | (declare (type fixnum i)) 87 | (cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0)) 88 | (cond ((fit i j) 89 | (setq k (place i j)) 90 | (cond ((or (trial k) 91 | (= k 0)) 92 | (setq **kount** (the fixnum (+ **kount** 1))) 93 | (return t)) 94 | (t (puzzle-remove i j)))))))))) 95 | 96 | (defun definepiece (iclass ii jj kk) 97 | (declare (type fixnum ii jj kk)) 98 | (let ((index 0)) 99 | (declare (type fixnum index)) 100 | (do ((i 0 (the fixnum (1+ i)))) 101 | ((> i ii)) 102 | (declare (type fixnum i)) 103 | (do ((j 0 (the fixnum (1+ j)))) 104 | ((> j jj)) 105 | (declare (type fixnum j)) 106 | (do ((k 0 (the fixnum (1+ k)))) 107 | ((> k kk)) 108 | (declare (type fixnum k)) 109 | (setq index 110 | (+ i 111 | (the fixnum 112 | (* puzzle-d 113 | (the fixnum 114 | (+ j 115 | (the fixnum 116 | (* puzzle-d k)))))))) 117 | (setf (aref puzzle-p **iii** index) t)))) 118 | (setf (aref puzzle-class **iii**) iclass) 119 | (setf (aref piecemax **iii**) index) 120 | (cond ((not (= **iii** puzzle-typemax)) 121 | (setq **iii** (the fixnum (+ **iii** 1))))))) 122 | 123 | (defun puzzle-start () 124 | (do ((m 0 (the fixnum (1+ m)))) 125 | ((> m puzzle-size)) 126 | (declare (type fixnum m)) 127 | (setf (aref puzzle m) t)) 128 | (do ((i 1 (the fixnum (1+ i)))) 129 | ((> i 5)) 130 | (declare (type fixnum i)) 131 | (do ((j 1 (the fixnum (1+ j)))) 132 | ((> j 5)) 133 | (declare (type fixnum j)) 134 | (do ((k 1 (the fixnum (1+ k)))) 135 | ((> k 5)) 136 | (declare (type fixnum k)) 137 | (setf (aref puzzle 138 | (+ i 139 | (the fixnum 140 | (* puzzle-d 141 | (the fixnum 142 | (+ j 143 | (the fixnum 144 | (* puzzle-d k)))))))) 145 | nil)))) 146 | (do ((i 0 (the fixnum (1+ i)))) 147 | ((> i puzzle-typemax)) 148 | (declare (type fixnum i)) 149 | (do ((m 0 (the fixnum (1+ m)))) 150 | ((> m puzzle-size)) 151 | (declare (type fixnum m)) 152 | (setf (aref puzzle-p i m) nil))) 153 | (setq **iii** 0) 154 | (definepiece 0 3 1 0) 155 | (definepiece 0 1 0 3) 156 | (definepiece 0 0 3 1) 157 | (definepiece 0 1 3 0) 158 | (definepiece 0 3 0 1) 159 | (definepiece 0 0 1 3) 160 | 161 | (definepiece 1 2 0 0) 162 | (definepiece 1 0 2 0) 163 | (definepiece 1 0 0 2) 164 | 165 | (definepiece 2 1 1 0) 166 | (definepiece 2 1 0 1) 167 | (definepiece 2 0 1 1) 168 | 169 | (definepiece 3 1 1 1) 170 | 171 | (setf (aref piececount 0) 13.) 172 | (setf (aref piececount 1) 3) 173 | (setf (aref piececount 2) 1) 174 | (setf (aref piececount 3) 1) 175 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 176 | (n 0)(**kount** 0)) 177 | (declare (type fixnum m n **kount**)) 178 | (cond ((fit 0 m) (setq n (place 0 m))) 179 | (t (format t "~%Error."))) 180 | (cond ((trial n) 181 | (format t "~%Success in ~4D trials." **kount**)) 182 | (t (format t "~%Failure."))))) 183 | 184 | (defun testpuzzle () 185 | (time (puzzle-start))) 186 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle-noproclaim.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle-noproclaim.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (defconstant puzzle-size 511.) 6 | (defconstant puzzle-classmax 3.) 7 | (defconstant puzzle-typemax 12.)) 8 | 9 | (defvar **iii** 0) 10 | (defvar **kount** 0) 11 | (defvar puzzle-d 8.) 12 | '(proclaim '(type fixnum **iii** **kount** puzzle-d)) 13 | 14 | (defvar piececount (make-array (1+ puzzle-classmax) :initial-element 0)) 15 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :initial-element 0)) 16 | (defvar piecemax (make-array (1+ puzzle-typemax) :initial-element 0)) 17 | (defvar puzzle (make-array (1+ puzzle-size))) 18 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 19 | 20 | ;;; Added the Lispworks conditionalization. Scott D. Anderson, 3/1/95 21 | 22 | '(proclaim '(type #-Lispworks simple-vector 23 | #+Lispworks (simple-array t) 24 | piececount puzzle-class piecemax puzzle)) 25 | 26 | '(proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 27 | puzzle-p)) 28 | 29 | (defun fit (i j) 30 | (declare (type fixnum i j)) 31 | (let ((end (aref piecemax i))) 32 | (declare (type fixnum end)) 33 | (do ((k 0 (the fixnum (1+ k)))) 34 | ((> k end) t) 35 | (declare (type fixnum k)) 36 | (cond ((aref puzzle-p i k) 37 | (cond ((aref puzzle (the fixnum (+ j k))) 38 | (return nil)))))))) 39 | 40 | (defun place (i j) 41 | (declare (type fixnum i j)) 42 | (let ((end (aref piecemax i))) 43 | (declare (type fixnum end)) 44 | (do ((k 0 (the fixnum (1+ k)))) 45 | ((> k end)) 46 | (declare (type fixnum k)) 47 | (cond ((aref puzzle-p i k) 48 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 49 | (setf (aref piececount (aref puzzle-class i)) 50 | (the fixnum 51 | (- (the fixnum 52 | (aref piececount (aref puzzle-class i))) 1))) 53 | (do ((k j (the fixnum (1+ k)))) 54 | ((> k puzzle-size) 55 | (terpri) 56 | (princ "Puzzle filled") 57 | 0) 58 | (declare (type fixnum k)) 59 | (cond ((not (aref puzzle k)) 60 | (return k)))))) 61 | 62 | 63 | (defun puzzle-remove (i j) 64 | (declare (type fixnum i j)) 65 | (let ((end (aref piecemax i))) 66 | (declare (type fixnum end)) 67 | (do ((k 0 (the fixnum (1+ k)))) 68 | ((> k end)) 69 | (declare (type fixnum k)) 70 | (cond ((aref puzzle-p i k) 71 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 72 | (setf (aref piececount (aref puzzle-class i)) 73 | (+ (the fixnum (aref piececount (aref puzzle-class i))) 1)))) 74 | 75 | (defun trial (j) 76 | (declare (type fixnum j)) 77 | (let ((k 0)) 78 | (declare (type fixnum k)) 79 | (do ((i 0 (the fixnum (1+ i)))) 80 | ((> i puzzle-typemax) 81 | (setq **kount** (the fixnum (1+ **kount**))) nil) 82 | (declare (type fixnum i)) 83 | (cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0)) 84 | (cond ((fit i j) 85 | (setq k (place i j)) 86 | (cond ((or (trial k) 87 | (= k 0)) 88 | (setq **kount** (the fixnum (+ **kount** 1))) 89 | (return t)) 90 | (t (puzzle-remove i j)))))))))) 91 | 92 | (defun definepiece (iclass ii jj kk) 93 | (declare (type fixnum ii jj kk)) 94 | (let ((index 0)) 95 | (declare (type fixnum index)) 96 | (do ((i 0 (the fixnum (1+ i)))) 97 | ((> i ii)) 98 | (declare (type fixnum i)) 99 | (do ((j 0 (the fixnum (1+ j)))) 100 | ((> j jj)) 101 | (declare (type fixnum j)) 102 | (do ((k 0 (the fixnum (1+ k)))) 103 | ((> k kk)) 104 | (declare (type fixnum k)) 105 | (setq index 106 | (+ i 107 | (the fixnum 108 | (* puzzle-d 109 | (the fixnum 110 | (+ j 111 | (the fixnum 112 | (* puzzle-d k)))))))) 113 | (setf (aref puzzle-p **iii** index) t)))) 114 | (setf (aref puzzle-class **iii**) iclass) 115 | (setf (aref piecemax **iii**) index) 116 | (cond ((not (= **iii** puzzle-typemax)) 117 | (setq **iii** (the fixnum (+ **iii** 1))))))) 118 | 119 | (defun puzzle-start () 120 | (do ((m 0 (the fixnum (1+ m)))) 121 | ((> m puzzle-size)) 122 | (declare (type fixnum m)) 123 | (setf (aref puzzle m) t)) 124 | (do ((i 1 (the fixnum (1+ i)))) 125 | ((> i 5)) 126 | (declare (type fixnum i)) 127 | (do ((j 1 (the fixnum (1+ j)))) 128 | ((> j 5)) 129 | (declare (type fixnum j)) 130 | (do ((k 1 (the fixnum (1+ k)))) 131 | ((> k 5)) 132 | (declare (type fixnum k)) 133 | (setf (aref puzzle 134 | (+ i 135 | (the fixnum 136 | (* puzzle-d 137 | (the fixnum 138 | (+ j 139 | (the fixnum 140 | (* puzzle-d k)))))))) 141 | nil)))) 142 | (do ((i 0 (the fixnum (1+ i)))) 143 | ((> i puzzle-typemax)) 144 | (declare (type fixnum i)) 145 | (do ((m 0 (the fixnum (1+ m)))) 146 | ((> m puzzle-size)) 147 | (declare (type fixnum m)) 148 | (setf (aref puzzle-p i m) nil))) 149 | (setq **iii** 0) 150 | (definepiece 0 3 1 0) 151 | (definepiece 0 1 0 3) 152 | (definepiece 0 0 3 1) 153 | (definepiece 0 1 3 0) 154 | (definepiece 0 3 0 1) 155 | (definepiece 0 0 1 3) 156 | 157 | (definepiece 1 2 0 0) 158 | (definepiece 1 0 2 0) 159 | (definepiece 1 0 0 2) 160 | 161 | (definepiece 2 1 1 0) 162 | (definepiece 2 1 0 1) 163 | (definepiece 2 0 1 1) 164 | 165 | (definepiece 3 1 1 1) 166 | 167 | (setf (aref piececount 0) 13.) 168 | (setf (aref piececount 1) 3) 169 | (setf (aref piececount 2) 1) 170 | (setf (aref piececount 3) 1) 171 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 172 | (n 0)(**kount** 0)) 173 | (declare (type fixnum m n **kount**)) 174 | (cond ((fit 0 m) (setq n (place 0 m))) 175 | (t (format t "~%Error."))) 176 | (cond ((trial n) 177 | (format t "~%Success in ~4D trials." **kount**)) 178 | (t (format t "~%Failure."))))) 179 | 180 | (defun testpuzzle () 181 | (time (puzzle-start))) 182 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle-sda.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle-sda.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (cl:spy *package*) ; SDA 6 | (defconstant puzzle-size 511.) 7 | (defconstant puzzle-classmax 3.) 8 | (defconstant puzzle-typemax 12.)) 9 | 10 | (defvar **iii** 0) 11 | (defvar **kount** 0) 12 | (defvar puzzle-d 8.) 13 | ;(proclaim '(type fixnum **iii** **kount** puzzle-d)) 14 | ;(declaim (type fixnum **iii** **kount** puzzle-d)) 15 | 16 | (defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0)) 17 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 18 | (defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0)) 19 | (defvar puzzle (make-array (1+ puzzle-size))) 20 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 21 | 22 | ;(proclaim '(type (array fixnum) piececount puzzle-class piecemax)) 23 | ;(declaim (type (array fixnum) piececount puzzle-class piecemax)) 24 | (defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i)))) 25 | 26 | 27 | ;(proclaim '(type simple-vector puzzle)) 28 | ;(declaim (type simple-vector puzzle)) 29 | 30 | ;(proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) 31 | ;(declaim (type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) puzzle-p)) 32 | 33 | (defun fit (i j) 34 | (declare (type fixnum i j)) 35 | (let ((end (fref piecemax i))) 36 | (declare (type fixnum end)) 37 | (do ((k 0 (the fixnum (1+ k)))) 38 | ((> k end) t) 39 | (declare (type fixnum k)) 40 | (cond ((aref puzzle-p i k) 41 | (cond ((aref puzzle (the fixnum (+ j k))) 42 | (return nil)))))))) 43 | 44 | ;(proclaim '(function place (fixnum fixnum ) fixnum)) 45 | ;(declaim (function place (fixnum fixnum ) fixnum)) 46 | 47 | (defun jil () 3) 48 | (defun place (i j) 49 | (declare (type fixnum i j)) 50 | (let ((end (fref piecemax i))) 51 | (declare (type fixnum end)) 52 | (do ((k 0 (the fixnum (1+ k)))) 53 | ((> k end)) 54 | (declare (type fixnum k)) 55 | (cond ((aref puzzle-p i k) 56 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 57 | (setf (fref piececount (fref puzzle-class i)) 58 | (the fixnum 59 | (- (the fixnum 60 | (fref piececount (fref puzzle-class i))) 1))) 61 | (do ((k j (the fixnum (1+ k)))) 62 | ((> k puzzle-size) 63 | (terpri) 64 | (princ "Puzzle filled") 65 | 0) 66 | (declare (type fixnum k)) 67 | (cond ((not (aref puzzle k)) 68 | (return k)))))) 69 | 70 | ;; SDA 71 | (eval-when (:compile-toplevel) 72 | (cl:spy (cl:macroexpand '(fref piececount (fref puzzle-class i))))) 73 | 74 | ;; SDA 75 | (defun test-fn1 (i) 76 | (declare (type fixnum i)) 77 | (setf (fref piececount (fref puzzle-class i)) 78 | (the fixnum 79 | (+ (the fixnum (fref piececount (fref puzzle-class i))) 1)))) 80 | 81 | ;; SDA 82 | (defun test-fn2 (i) 83 | (declare (type fixnum i)) 84 | (setf (the fixnum (aref piececount (the fixnum (aref puzzle-class i)))) 85 | (the fixnum 86 | (+ (the fixnum (the fixnum (aref piececount (the fixnum (aref puzzle-class i))))) 1)))) 87 | 88 | ;; SDA 89 | (defun test-fn3 (i) 90 | (declare (type fixnum i)) 91 | (setf (the fixnum (aref piececount (the fixnum i))) 92 | (the fixnum 93 | (+ (the fixnum i) 1)))) 94 | 95 | ;; SDA 96 | (defun test-fn4 (i) 97 | (declare (type fixnum i)) 98 | (setf (the fixnum (aref piececount i)) 99 | (1+ i))) 100 | 101 | ;; SDA 102 | (defun test-fn5 (i) 103 | (declare (type fixnum i)) 104 | (setf (aref piececount i) 105 | (1+ i))) 106 | 107 | ;(cl:in-package :cl-user) 108 | 109 | ;; SDA 110 | (defun test-fn6 (i) 111 | (declare (type fixnum i)) 112 | (setf (aref piececount i) 113 | (1+ i))) 114 | 115 | (defun puzzle-remove (i j) 116 | (declare (type fixnum i j)) 117 | (let ((end (fref piecemax i))) 118 | (declare (type fixnum end)) 119 | (do ((k 0 (the fixnum (1+ k)))) 120 | ((> k end)) 121 | (declare (type fixnum k)) 122 | (cond ((aref puzzle-p i k) 123 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 124 | (setf (fref piececount (fref puzzle-class i)) 125 | (the fixnum 126 | (+ (the fixnum (fref piececount (fref puzzle-class i))) 1))))) 127 | 128 | (defun trial (j) 129 | (declare (type fixnum j)) 130 | (let ((k 0)) 131 | (declare (type fixnum k)) 132 | (do ((i 0 (the fixnum (1+ i)))) 133 | ((> i puzzle-typemax) 134 | (setq **kount** (the fixnum (1+ **kount**))) nil) 135 | (declare (type fixnum i)) 136 | (cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0)) 137 | (cond ((fit i j) 138 | (setq k (place i j)) 139 | (cond ((or (trial k) 140 | (= k 0)) 141 | (setq **kount** (the fixnum (+ **kount** 1))) 142 | (return t)) 143 | (t (puzzle-remove i j)))))))))) 144 | 145 | (defun definepiece (iclass ii jj kk) 146 | (declare (type fixnum ii jj kk)) 147 | (let ((index 0)) 148 | (declare (type fixnum index)) 149 | (do ((i 0 (the fixnum (1+ i)))) 150 | ((> i ii)) 151 | (declare (type fixnum i)) 152 | (do ((j 0 (the fixnum (1+ j)))) 153 | ((> j jj)) 154 | (declare (type fixnum j)) 155 | (do ((k 0 (the fixnum (1+ k)))) 156 | ((> k kk)) 157 | (declare (type fixnum k)) 158 | (setq index 159 | (+ i 160 | (the fixnum 161 | (* puzzle-d 162 | (the fixnum 163 | (+ j 164 | (the fixnum 165 | (* puzzle-d k)))))))) 166 | (setf (aref puzzle-p **iii** index) t)))) 167 | (setf (fref puzzle-class **iii**) iclass) 168 | (setf (fref piecemax **iii**) index) 169 | (cond ((not (= **iii** puzzle-typemax)) 170 | (setq **iii** (the fixnum (+ **iii** 1))))))) 171 | 172 | (defun puzzle-start () 173 | (do ((m 0 (the fixnum (1+ m)))) 174 | ((> m puzzle-size)) 175 | (declare (type fixnum m)) 176 | (setf (aref puzzle m) t)) 177 | (do ((i 1 (the fixnum (1+ i)))) 178 | ((> i 5)) 179 | (declare (type fixnum i)) 180 | (do ((j 1 (the fixnum (1+ j)))) 181 | ((> j 5)) 182 | (declare (type fixnum j)) 183 | (do ((k 1 (the fixnum (1+ k)))) 184 | ((> k 5)) 185 | (declare (type fixnum k)) 186 | (setf (aref puzzle 187 | (+ i 188 | (the fixnum 189 | (* puzzle-d 190 | (the fixnum 191 | (+ j 192 | (the fixnum 193 | (* puzzle-d k)))))))) 194 | nil)))) 195 | (do ((i 0 (the fixnum (1+ i)))) 196 | ((> i puzzle-typemax)) 197 | (declare (type fixnum i)) 198 | (do ((m 0 (the fixnum (1+ m)))) 199 | ((> m puzzle-size)) 200 | (declare (type fixnum m)) 201 | (setf (aref puzzle-p i m) nil))) 202 | (setq **iii** 0) 203 | (definepiece 0 3 1 0) 204 | (definepiece 0 1 0 3) 205 | (definepiece 0 0 3 1) 206 | (definepiece 0 1 3 0) 207 | (definepiece 0 3 0 1) 208 | (definepiece 0 0 1 3) 209 | 210 | (definepiece 1 2 0 0) 211 | (definepiece 1 0 2 0) 212 | (definepiece 1 0 0 2) 213 | 214 | (definepiece 2 1 1 0) 215 | (definepiece 2 1 0 1) 216 | (definepiece 2 0 1 1) 217 | 218 | (definepiece 3 1 1 1) 219 | 220 | (setf (fref piececount 0) 13.) 221 | (setf (fref piececount 1) 3) 222 | (setf (fref piececount 2) 1) 223 | (setf (fref piececount 3) 1) 224 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 225 | (n 0)(**kount** 0)) 226 | (declare (type fixnum m n **kount**)) 227 | (cond ((fit 0 m) (setq n (place 0 m))) 228 | (t (format t "~%Error."))) 229 | (cond ((trial n) 230 | (format t "~%Success in ~4D trials." **kount**)) 231 | (t (format t "~%Failure."))))) 232 | 233 | (defun testpuzzle () 234 | (time (puzzle-start))) 235 | -------------------------------------------------------------------------------- /contrib/gabriel/puzzle.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/puzzle.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | (eval-when (compile load eval) 5 | (spy *package*) 6 | (defconstant puzzle-size 511.) 7 | (defconstant puzzle-classmax 3.) 8 | (defconstant puzzle-typemax 12.)) 9 | 10 | (defvar **iii** 0) 11 | (defvar **kount** 0) 12 | (defvar puzzle-d 8.) 13 | (proclaim '(type fixnum **iii** **kount** puzzle-d)) 14 | 15 | (defvar piececount (make-array (1+ puzzle-classmax) :initial-element 0)) 16 | (defvar puzzle-class (make-array (1+ puzzle-typemax) :initial-element 0)) 17 | (defvar piecemax (make-array (1+ puzzle-typemax) :initial-element 0)) 18 | (defvar puzzle (make-array (1+ puzzle-size))) 19 | (defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size)))) 20 | 21 | ;;; Added the Lispworks conditionalization. Scott D. Anderson, 3/1/95 22 | 23 | (proclaim '(type #-Lispworks simple-vector 24 | #+Lispworks (simple-array t) 25 | piececount puzzle-class piecemax puzzle)) 26 | 27 | (proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size))) 28 | puzzle-p)) 29 | 30 | (defun fit (i j) 31 | (declare (type fixnum i j)) 32 | (let ((end (aref piecemax i))) 33 | (declare (type fixnum end)) 34 | (do ((k 0 (the fixnum (1+ k)))) 35 | ((> k end) t) 36 | (declare (type fixnum k)) 37 | (cond ((aref puzzle-p i k) 38 | (cond ((aref puzzle (the fixnum (+ j k))) 39 | (return nil)))))))) 40 | 41 | (defun place (i j) 42 | (declare (type fixnum i j)) 43 | (let ((end (aref piecemax i))) 44 | (declare (type fixnum end)) 45 | (do ((k 0 (the fixnum (1+ k)))) 46 | ((> k end)) 47 | (declare (type fixnum k)) 48 | (cond ((aref puzzle-p i k) 49 | (setf (aref puzzle (the fixnum (+ j k))) t)))) 50 | (setf (aref piececount (aref puzzle-class i)) 51 | (the fixnum 52 | (- (the fixnum 53 | (aref piececount (aref puzzle-class i))) 1))) 54 | (do ((k j (the fixnum (1+ k)))) 55 | ((> k puzzle-size) 56 | (terpri) 57 | (princ "Puzzle filled") 58 | 0) 59 | (declare (type fixnum k)) 60 | (cond ((not (aref puzzle k)) 61 | (return k)))))) 62 | 63 | 64 | (defun puzzle-remove (i j) 65 | (declare (type fixnum i j)) 66 | (let ((end (aref piecemax i))) 67 | (declare (type fixnum end)) 68 | (do ((k 0 (the fixnum (1+ k)))) 69 | ((> k end)) 70 | (declare (type fixnum k)) 71 | (cond ((aref puzzle-p i k) 72 | (setf (aref puzzle (the fixnum (+ j k))) nil)))) 73 | (setf (aref piececount (aref puzzle-class i)) 74 | (+ (the fixnum (aref piececount (aref puzzle-class i))) 1)))) 75 | 76 | (defun trial (j) 77 | (declare (type fixnum j)) 78 | (let ((k 0)) 79 | (declare (type fixnum k)) 80 | (do ((i 0 (the fixnum (1+ i)))) 81 | ((> i puzzle-typemax) 82 | (setq **kount** (the fixnum (1+ **kount**))) nil) 83 | (declare (type fixnum i)) 84 | (cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0)) 85 | (cond ((fit i j) 86 | (setq k (place i j)) 87 | (cond ((or (trial k) 88 | (= k 0)) 89 | (setq **kount** (the fixnum (+ **kount** 1))) 90 | (return t)) 91 | (t (puzzle-remove i j)))))))))) 92 | 93 | (defun definepiece (iclass ii jj kk) 94 | (declare (type fixnum ii jj kk)) 95 | (let ((index 0)) 96 | (declare (type fixnum index)) 97 | (do ((i 0 (the fixnum (1+ i)))) 98 | ((> i ii)) 99 | (declare (type fixnum i)) 100 | (do ((j 0 (the fixnum (1+ j)))) 101 | ((> j jj)) 102 | (declare (type fixnum j)) 103 | (do ((k 0 (the fixnum (1+ k)))) 104 | ((> k kk)) 105 | (declare (type fixnum k)) 106 | (setq index 107 | (+ i 108 | (the fixnum 109 | (* puzzle-d 110 | (the fixnum 111 | (+ j 112 | (the fixnum 113 | (* puzzle-d k)))))))) 114 | (setf (aref puzzle-p **iii** index) t)))) 115 | (setf (aref puzzle-class **iii**) iclass) 116 | (setf (aref piecemax **iii**) index) 117 | (cond ((not (= **iii** puzzle-typemax)) 118 | (setq **iii** (the fixnum (+ **iii** 1))))))) 119 | 120 | (defun puzzle-start () 121 | (do ((m 0 (the fixnum (1+ m)))) 122 | ((> m puzzle-size)) 123 | (declare (type fixnum m)) 124 | (setf (aref puzzle m) t)) 125 | (do ((i 1 (the fixnum (1+ i)))) 126 | ((> i 5)) 127 | (declare (type fixnum i)) 128 | (do ((j 1 (the fixnum (1+ j)))) 129 | ((> j 5)) 130 | (declare (type fixnum j)) 131 | (do ((k 1 (the fixnum (1+ k)))) 132 | ((> k 5)) 133 | (declare (type fixnum k)) 134 | (setf (aref puzzle 135 | (+ i 136 | (the fixnum 137 | (* puzzle-d 138 | (the fixnum 139 | (+ j 140 | (the fixnum 141 | (* puzzle-d k)))))))) 142 | nil)))) 143 | (do ((i 0 (the fixnum (1+ i)))) 144 | ((> i puzzle-typemax)) 145 | (declare (type fixnum i)) 146 | (do ((m 0 (the fixnum (1+ m)))) 147 | ((> m puzzle-size)) 148 | (declare (type fixnum m)) 149 | (setf (aref puzzle-p i m) nil))) 150 | (setq **iii** 0) 151 | (definepiece 0 3 1 0) 152 | (definepiece 0 1 0 3) 153 | (definepiece 0 0 3 1) 154 | (definepiece 0 1 3 0) 155 | (definepiece 0 3 0 1) 156 | (definepiece 0 0 1 3) 157 | 158 | (definepiece 1 2 0 0) 159 | (definepiece 1 0 2 0) 160 | (definepiece 1 0 0 2) 161 | 162 | (definepiece 2 1 1 0) 163 | (definepiece 2 1 0 1) 164 | (definepiece 2 0 1 1) 165 | 166 | (definepiece 3 1 1 1) 167 | 168 | (setf (aref piececount 0) 13.) 169 | (setf (aref piececount 1) 3) 170 | (setf (aref piececount 2) 1) 171 | (setf (aref piececount 3) 1) 172 | (let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d)))))) 173 | (n 0)(**kount** 0)) 174 | (declare (type fixnum m n **kount**)) 175 | (cond ((fit 0 m) (setq n (place 0 m))) 176 | (t (format t "~%Error."))) 177 | (cond ((trial n) 178 | (format t "~%Success in ~4D trials." **kount**)) 179 | (t (format t "~%Failure."))))) 180 | 181 | (defun testpuzzle () 182 | (time (puzzle-start))) 183 | -------------------------------------------------------------------------------- /contrib/gabriel/stak.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/stak.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; STAK -- The TAKeuchi function with special variables instead of 5 | ;;; parameter passing. 6 | 7 | (defvar stak-x) 8 | (defvar stak-y) 9 | (defvar stak-z) 10 | (proclaim '(type fixnum stak-x stak-y stak-z)) 11 | 12 | (defun stak (stak-x stak-y stak-z) 13 | (stak-aux)) 14 | 15 | (defun stak-aux () 16 | (if (not (< stak-y stak-x)) 17 | stak-z 18 | (let ((stak-x (let ((stak-x (the fixnum (1- stak-x))) 19 | (stak-y stak-y) 20 | (stak-z stak-z)) 21 | (stak-aux))) 22 | (stak-y (let ((stak-x (the fixnum (1- stak-y))) 23 | (stak-y stak-z) 24 | (stak-z stak-x)) 25 | (stak-aux))) 26 | (stak-z (let ((stak-x (the fixnum (1- stak-z))) 27 | (stak-y stak-x) 28 | (stak-z stak-y)) 29 | (stak-aux)))) 30 | (stak-aux)))) 31 | 32 | (defun teststak () 33 | (print (time (stak 18 12 6)))) 34 | -------------------------------------------------------------------------------- /contrib/gabriel/tak-mod.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/tak-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | #+excl 5 | (eval-when (compile) (setq comp::register-use-threshold 6)) 6 | 7 | (proclaim '(function tak (fixnum fixnum fixnum) fixnum)) 8 | 9 | (defun tak (x y z) 10 | (declare (type fixnum x y z)) 11 | (cond ((not (< y x)) z) 12 | (t 13 | (tak 14 | (tak (the fixnum (1- x)) y z) 15 | (tak (the fixnum (1- y)) z x) 16 | (tak (the fixnum (1- z)) x y))))) 17 | 18 | (defun testtak () 19 | (print (time 20 | (progn (tak 18 12 6) 21 | (tak 18 12 6) 22 | (tak 18 12 6) 23 | (tak 18 12 6) 24 | (tak 18 12 6) 25 | (tak 18 12 6) 26 | (tak 18 12 6) 27 | (tak 18 12 6) 28 | (tak 18 12 6) 29 | (tak 18 12 6))))) 30 | 31 | #+excl (eval-when (compile) (setq comp::register-use-threshold 3)) 32 | -------------------------------------------------------------------------------- /contrib/gabriel/tak.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/tak.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | #+excl 5 | (eval-when (compile) (setq comp::register-use-threshold 6)) 6 | 7 | (defun tak (x y z) 8 | (declare (fixnum x y z)) 9 | (cond ((not (< y x)) z) 10 | (t 11 | (tak 12 | (tak (the fixnum (1- x)) y z) 13 | (tak (the fixnum (1- y)) z x) 14 | (tak (the fixnum (1- z)) x y))))) 15 | 16 | (defun testtak () 17 | (print (time 18 | (progn (tak 18 12 6) 19 | (tak 18 12 6) 20 | (tak 18 12 6) 21 | (tak 18 12 6) 22 | (tak 18 12 6) 23 | (tak 18 12 6) 24 | (tak 18 12 6) 25 | (tak 18 12 6) 26 | (tak 18 12 6) 27 | (tak 18 12 6))))) 28 | 29 | #+excl (eval-when (compile) (setq comp::register-use-threshold 3)) 30 | -------------------------------------------------------------------------------- /contrib/gabriel/takl.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/takl.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; TAKL -- The TAKeuchi function using lists as counters. 5 | 6 | (defun listn (n) 7 | (declare (type fixnum n)) 8 | (if (not (= 0 n)) 9 | (cons n (listn (the fixnum (1- n)))))) 10 | 11 | (defvar 18l (listn 18)) 12 | (defvar 12l (listn 12)) 13 | (defvar 6l (listn 6)) 14 | 15 | (defun mas (x y z) 16 | (if (not (shorterp y x)) 17 | z 18 | (mas (mas (cdr x) y z) 19 | (mas (cdr y) z x) 20 | (mas (cdr z) x y)))) 21 | 22 | (defun shorterp (x y) 23 | (and y (or (null x) 24 | (shorterp (cdr x) (cdr y))))) 25 | 26 | (defun testtakl () 27 | (print (time (mas 18l 12l 6l)))) 28 | -------------------------------------------------------------------------------- /contrib/gabriel/tprint.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/tprint.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; TPRINT -- Benchmark to print and read to the terminal. 5 | 6 | (defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9 7 | stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d 8 | 567d 678e 789f 890g)) 9 | 10 | (defun tprint-init (m n atoms) 11 | (let ((atoms (subst () () atoms))) 12 | (do ((a atoms (cdr a))) 13 | ((null (cdr a)) (rplacd a atoms))) 14 | (tprint-init-aux m n atoms))) 15 | 16 | (defun tprint-init-aux (m n atoms) 17 | (declare (type fixnum m n)) 18 | (cond ((= m 0) (pop atoms)) 19 | (t (do ((i n (the fixnum (- i 2))) 20 | (a ())) 21 | ((< i 1) a) 22 | (push (pop atoms) a) 23 | (push (tprint-init-aux (the fixnum (1- m)) n atoms) a))))) 24 | 25 | (defvar test-pattern (tprint-init 6. 6. test-atoms)) 26 | 27 | 28 | (defun standard-tprint-test () 29 | (print test-pattern)) 30 | 31 | (defun testtprint () 32 | (print (time (print test-pattern)))) 33 | -------------------------------------------------------------------------------- /contrib/gabriel/traverse.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/traverse.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; TRAVERSE -- Benchmark which creates and traverses a tree structure. 5 | 6 | 7 | (eval-when (eval compile load) 8 | (defstruct node 9 | (parents ()) 10 | (sons ()) 11 | (sn (snb)) 12 | (entry1 ()) 13 | (entry2 ()) 14 | (entry3 ()) 15 | (entry4 ()) 16 | (entry5 ()) 17 | (entry6 ()) 18 | (mark ())) 19 | ) 20 | (defvar traverse-sn 0) 21 | (defvar traverse-rand 21.) 22 | (defvar traverse-count 0) 23 | (proclaim `(type fixnum traverse-sn traverse-rand traverse-count)) 24 | (defvar traverse-marker nil) 25 | (defvar traverse-root) 26 | 27 | (setq traverse-sn 0 traverse-rand 21 traverse-count 0 traverse-marker nil) 28 | 29 | (defun snb () 30 | (setq traverse-sn (the fixnum (1+ traverse-sn)))) 31 | 32 | (defun traverse-seed () 33 | (setq traverse-rand 21.)) 34 | 35 | (defun traverse-random () 36 | (setq traverse-rand 37 | (the fixnum (rem (the fixnum (* traverse-rand 17)) 251)))) 38 | 39 | (defun traverse-remove (n q) 40 | (declare (type fixnum n)) 41 | (cond ((eq (cdr (car q)) (car q)) 42 | (prog2 () (caar q) (rplaca q ()))) 43 | ((= n 0) 44 | (prog2 () (caar q) 45 | (do ((p (car q) (cdr p))) 46 | ((eq (cdr p) (car q)) 47 | (rplaca q 48 | (rplacd p (cdr (car q)))))))) 49 | (t (do ((n n (the fixnum (1- n))) 50 | (q (car q) (cdr q)) 51 | (p (cdr (car q)) (cdr p))) 52 | ((= n 0) (prog2 () (car q) (rplacd q p))) 53 | (declare (type fixnum n)))))) 54 | 55 | (defun traverse-select (n q) 56 | (declare (type fixnum n)) 57 | (do ((n n (the fixnum (1- n))) 58 | (q (car q) (cdr q))) 59 | ((= n 0) (car q)) 60 | (declare (type fixnum n)))) 61 | 62 | (defun traverse-add (a q) 63 | (cond ((null q) 64 | `(,(let ((x `(,a))) 65 | (rplacd x x) x))) 66 | ((null (car q)) 67 | (let ((x `(,a))) 68 | (rplacd x x) 69 | (rplaca q x))) 70 | (t (rplaca q 71 | (rplacd (car q) `(,a .,(cdr (car q)))))))) 72 | 73 | (defun traverse-create-structure (n) 74 | (declare (type fixnum n)) 75 | (let ((a `(,(make-node)))) 76 | (do ((m (the fixnum (1- n)) (the fixnum (1- m))) 77 | (p a)) 78 | ((= m 0) (setq a `(,(rplacd p a))) 79 | (do ((unused a) 80 | (used (traverse-add (traverse-remove 0 a) ())) 81 | (x) (y)) 82 | ((null (car unused)) 83 | (find-root (traverse-select 0 used) n)) 84 | (setq x (traverse-remove 85 | (the fixnum (rem (the fixnum (traverse-random)) n)) 86 | unused)) 87 | (setq y (traverse-select 88 | (the fixnum (rem (the fixnum (traverse-random)) n)) 89 | used)) 90 | (traverse-add x used) 91 | (setf (node-sons y) `(,x .,(node-sons y))) 92 | (setf (node-parents x) `(,y .,(node-parents x))) )) 93 | (declare (type fixnum m)) 94 | (push (make-node) a)))) 95 | 96 | (defun find-root (node n) 97 | (declare (type fixnum n)) 98 | (do ((n n (the fixnum (1- n)))) 99 | ((= n 0) node) 100 | (declare (type fixnum n)) 101 | (cond ((null (node-parents node)) 102 | (return node)) 103 | (t (setq node (car (node-parents node))))))) 104 | 105 | (defun travers (node mark) 106 | (cond ((eq (node-mark node) mark) ()) 107 | (t (setf (node-mark node) mark) 108 | (setq traverse-count (the fixnum (1+ traverse-count))) 109 | (setf (node-entry1 node) (not (node-entry1 node))) 110 | (setf (node-entry2 node) (not (node-entry2 node))) 111 | (setf (node-entry3 node) (not (node-entry3 node))) 112 | (setf (node-entry4 node) (not (node-entry4 node))) 113 | (setf (node-entry5 node) (not (node-entry5 node))) 114 | (setf (node-entry6 node) (not (node-entry6 node))) 115 | (do ((sons (node-sons node) (cdr sons))) 116 | ((null sons) ()) 117 | (travers (car sons) mark))))) 118 | 119 | 120 | 121 | (defun traverse (traverse-root) 122 | (let ((traverse-count 0)) 123 | (declare (type fixnum traverse-count)) 124 | (travers traverse-root 125 | (setq traverse-marker (not traverse-marker))) 126 | traverse-count)) 127 | 128 | (defun init-traverse() 129 | (setq traverse-root (traverse-create-structure 100.)) 130 | nil) 131 | 132 | (defun run-traverse () 133 | (do ((i 50 (the fixnum (1- (the fixnum i))))) 134 | ((= (the fixnum i) 0)) 135 | (declare (type fixnum i)) 136 | (traverse traverse-root) 137 | (traverse traverse-root) 138 | (traverse traverse-root) 139 | (traverse traverse-root) 140 | (traverse traverse-root))) 141 | 142 | (defun testtraverse () 143 | (testtraverse-init) 144 | (testtraverse-run)) 145 | 146 | (defun testtraverse-init () 147 | (print (time (init-traverse)))) 148 | 149 | (defun testtraverse-run () 150 | (print (time (run-traverse)))) 151 | -------------------------------------------------------------------------------- /contrib/gabriel/triang-mod.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/triang-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; TRIANG -- Board game benchmark. 5 | 6 | ;;; Renamed the `sequence' variable to `the-sequence' so that there will be no 7 | ;;; complains when it is proclaimed special. Also changed the use of 8 | ;;; (eq 1 (aref ...)) to (eql 1 (aref ...)) 9 | ;;; 10 | ;;; -- Scott D. Anderson, anderson@cs.umass.edu, 4/30/95 11 | 12 | 13 | (proclaim '(special board the-sequence a b c)) 14 | (proclaim '(special board the-sequence a b c)) 15 | (proclaim '(type (vector fixnum ) board)) 16 | (proclaim '(type (vector fixnum ) the-sequence)) 17 | (proclaim '(type (vector fixnum ) a)) 18 | (proclaim '(type (vector fixnum ) b)) 19 | (proclaim '(type (vector fixnum ) c)) 20 | (defvar answer) 21 | (defvar final) 22 | (proclaim '(function triang-setup () t)) 23 | (proclaim '(function last-position () fixnum)) 24 | (proclaim '(function try (fixnum fixnum) t)) 25 | (proclaim '(function simple-vector-to-list (t) t)) 26 | (proclaim '(function gogogo (fixnum) t)) 27 | (proclaim '(function testtriang () t)) 28 | 29 | (defun triang-setup () 30 | (setq board (make-array 16 :element-type 'fixnum :initial-element 1)) 31 | (setq the-sequence (make-array 14 :element-type 'fixnum :initial-element 0)) 32 | (setq a 33 | (make-array 34 | 37 35 | :element-type 'fixnum 36 | :initial-contents 37 | '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 38 | 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) 39 | (setq b (make-array 40 | 37 41 | :element-type 'fixnum 42 | :initial-contents 43 | '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 44 | 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) 45 | (setq c (make-array 46 | 37 47 | :element-type 'fixnum 48 | :initial-contents 49 | '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 50 | 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) 51 | (setf (aref board 5) 0)) 52 | 53 | (defun last-position () 54 | (do ((i 1 (the fixnum (+ i 1)))) 55 | ((= i 16) 0) 56 | (declare (type fixnum i)) 57 | (if (eql 1 (aref board i)) 58 | (return i)))) 59 | 60 | (defun try (i depth) 61 | (declare (type fixnum i depth)) 62 | (cond ((= depth 14) 63 | (let ((lp (last-position))) 64 | (unless (member lp final :test #'eq) 65 | (push lp final))) 66 | ;;; (format t "~&~s" (cdr (simple-vector-to-list the-sequence))) 67 | (push (cdr (simple-vector-to-list the-sequence)) 68 | answer) t) ; this is a hack to replace LISTARRAY 69 | ((and (eql 1 (aref board (aref a i))) 70 | (eql 1 (aref board (aref b i))) 71 | (eql 0 (aref board (aref c i)))) 72 | (setf (aref board (aref a i)) 0) 73 | (setf (aref board (aref b i)) 0) 74 | (setf (aref board (aref c i)) 1) 75 | (setf (aref the-sequence depth) i) 76 | (do ((j 0 (the fixnum (+ j 1))) 77 | (depth (the fixnum (+ depth 1)))) 78 | ((or (= j 36) 79 | (try j depth)) ()) 80 | (declare (type fixnum j depth))) 81 | (setf (aref board (aref a i)) 1) 82 | (setf (aref board (aref b i)) 1) 83 | (setf (aref board (aref c i)) 0) ()))) 84 | 85 | (defun simple-vector-to-list (seq) 86 | (do ((i (- (length seq) 1) (1- i)) 87 | (res)) 88 | ((< i 0) 89 | res) 90 | (declare (type fixnum i)) 91 | (push (aref seq i) res))) 92 | 93 | (defun gogogo (i) 94 | (let ((answer ()) 95 | (final ())) 96 | (try i 1))) 97 | 98 | (defun testtriang () 99 | (triang-setup) 100 | (print (time (gogogo 22)))) 101 | -------------------------------------------------------------------------------- /contrib/gabriel/triang-old-mod.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/triang-old-mod.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; TRIANG -- Board game benchmark. 5 | 6 | (proclaim '(special board sequence a b c)) 7 | 8 | (proclaim '(type (vector fixnum) a b c)) 9 | (defmacro fref (v i) `(the fixnum (aref (the (vector fixnum) ,v) ,i))) 10 | 11 | (defvar answer) 12 | (defvar final) 13 | 14 | (defun triang-setup () 15 | (setq board (make-array 16 :initial-element 1)) 16 | (setq sequence (make-array 14 :initial-element 0)) 17 | (setq a 18 | (make-array 19 | 37 20 | :element-type 'fixnum :initial-contents 21 | '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 22 | 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) 23 | (setq b (make-array 24 | 37 :element-type 'fixnum :initial-contents 25 | '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 26 | 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) 27 | (setq c (make-array 28 | 37 :element-type 'fixnum :initial-contents 29 | '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 30 | 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) 31 | (setf (svref board 5) 0)) 32 | 33 | 34 | (defun last-position () 35 | (do ((i 1 (the fixnum (+ i 1)))) 36 | ((= i 16) 0) 37 | (declare (type fixnum i)) 38 | (if (eq 1 (svref board i)) 39 | (return i)))) 40 | (proclaim '(function try (fixnum fixnum) t)) 41 | (defun try (i depth) 42 | (declare (type fixnum i depth)) 43 | (cond ((= depth 14) 44 | (let ((lp (last-position))) 45 | (unless (member lp final :test #'eq) 46 | (push lp final))) 47 | (push (cdr (simple-vector-to-list sequence)) 48 | answer) t) ; this is a hack to replace LISTARRAY 49 | ((and (eq 1 (svref board (fref a i))) 50 | (eq 1 (svref board (fref b i))) 51 | (eq 0 (svref board (fref c i)))) 52 | (setf (svref board (fref a i)) 0) 53 | (setf (svref board (fref b i)) 0) 54 | (setf (svref board (fref c i)) 1) 55 | (setf (svref sequence depth) i) 56 | (do ((j 0 (the fixnum (+ j 1))) 57 | (depth (the fixnum (+ depth 1)))) 58 | ((or (= j 36) 59 | (try j depth)) ()) 60 | (declare (type fixnum j depth))) 61 | (setf (svref board (fref a i)) 1) 62 | (setf (svref board (fref b i)) 1) 63 | (setf (svref board (fref c i)) 0) ()))) 64 | 65 | (defun simple-vector-to-list (seq) 66 | (do ((i (- (length seq) 1) (1- i)) 67 | (res)) 68 | ((< i 0) 69 | res) 70 | (declare (type fixnum i)) 71 | (push (svref seq i) res))) 72 | 73 | (defun gogogo (i) 74 | (let ((answer ()) 75 | (final ())) 76 | (try i 1))) 77 | 78 | (defun testtriang () 79 | (triang-setup) 80 | (print (time (gogogo 22)))) 81 | -------------------------------------------------------------------------------- /contrib/gabriel/triang.lisp: -------------------------------------------------------------------------------- 1 | ;; $Header: /usr/local/cvsroot/emacs-cl/contrib/gabriel/triang.cl,v 1.1 2004/05/05 05:41:56 lars Exp $ 2 | ;; $Locker: $ 3 | 4 | ;;; TRIANG -- Board game benchmark. 5 | 6 | ;;; Renamed the `sequence' variable to `the-sequence' so that there will be no 7 | ;;; complains when it is proclaimed special. Also changed the use of 8 | ;;; (eq 1 (svref ...)) to (eql 1 (svref ...)) 9 | ;;; 10 | ;;; -- Scott D. Anderson, anderson@cs.umass.edu, 4/30/95 11 | 12 | (proclaim '(special board the-sequence a b c)) 13 | (defvar answer) 14 | (defvar final) 15 | 16 | (defun triang-setup () 17 | (setq board (make-array 16 :initial-element 1)) 18 | (setq the-sequence (make-array 14 :initial-element 0)) 19 | (setq a 20 | (make-array 21 | 37 22 | :initial-contents 23 | '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 24 | 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) 25 | (setq b (make-array 26 | 37 :initial-contents 27 | '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 28 | 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) 29 | (setq c (make-array 30 | 37 :initial-contents 31 | '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 32 | 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) 33 | (setf (svref board 5) 0)) 34 | 35 | (defun last-position () 36 | (do ((i 1 (the fixnum (+ i 1)))) 37 | ((= i 16) 0) 38 | (declare (type fixnum i)) 39 | (if (eql 1 (svref board i)) 40 | (return i)))) 41 | 42 | (defun try (i depth) 43 | (declare (type fixnum i depth)) 44 | (cond ((= depth 14) 45 | (let ((lp (last-position))) 46 | (unless (member lp final :test #'eq) 47 | (push lp final))) 48 | (push (cdr (simple-vector-to-list the-sequence)) 49 | answer) t) ; this is a hack to replace LISTARRAY 50 | ((and (eql 1 (svref board (svref a i))) 51 | (eql 1 (svref board (svref b i))) 52 | (eql 0 (svref board (svref c i)))) 53 | (setf (svref board (svref a i)) 0) 54 | (setf (svref board (svref b i)) 0) 55 | (setf (svref board (svref c i)) 1) 56 | (setf (svref the-sequence depth) i) 57 | (do ((j 0 (the fixnum (+ j 1))) 58 | (depth (the fixnum (+ depth 1)))) 59 | ((or (= j 36) 60 | (try j depth)) ()) 61 | (declare (type fixnum j depth))) 62 | (setf (svref board (svref a i)) 1) 63 | (setf (svref board (svref b i)) 1) 64 | (setf (svref board (svref c i)) 0) ()))) 65 | 66 | (defun simple-vector-to-list (seq) 67 | (do ((i (- (length seq) 1) (1- i)) 68 | (res)) 69 | ((< i 0) 70 | res) 71 | (declare (type fixnum i)) 72 | (push (svref seq i) res))) 73 | 74 | (defun gogogo (i) 75 | (let ((answer ()) 76 | (final ())) 77 | (try i 1))) 78 | 79 | (defun testtriang () 80 | (triang-setup) 81 | (print (time (gogogo 22)))) 82 | -------------------------------------------------------------------------------- /emacs-cl-pkg.el: -------------------------------------------------------------------------------- 1 | (define-package "emacs-cl" "VERSION" 2 | "Emacs Common Lisp") 3 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2003, 2004 Lars Brinkhoff. 2 | 3 | #EMACS = emacs19 4 | EMACS = emacs20 5 | #EMACS = emacs21 6 | #EMACS = xemacs20 7 | #EMACS = xemacs21 8 | 9 | EMACSEN = emacs20 emacs21 xemacs21 # ../emacs-19.34/src/emacs 10 | 11 | all: 12 | $(EMACS) -batch -l load-cl.el -f compile-cl 13 | 14 | #install: 15 | 16 | TESTFILES = -l load-cl.el -l batch.el -l tests.el 17 | 18 | check: 19 | mv check.log previous.log 2> /dev/null 20 | for e in $(EMACSEN); do \ 21 | echo CHECKING $$e; \ 22 | make clean > /dev/null; \ 23 | echo Interpreting...; \ 24 | $$e -batch $(TESTFILES) -f test-cl 2> /dev/null; \ 25 | echo Compiling...; \ 26 | make EMACS=$$e > /dev/null 2>&1; \ 27 | $$e -batch $(TESTFILES) -f test-cl 2> /dev/null; \ 28 | done | tee check.log 29 | make clean 30 | 31 | clean: 32 | rm -f *.elc 33 | -------------------------------------------------------------------------------- /src/batch.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; Batch-mode REPL. This code is used by the "emacs-cl" script. 5 | 6 | (setq *STANDARD-OUTPUT* (make-princ-stream) 7 | *ERROR-OUTPUT* *STANDARD-OUTPUT* 8 | *TRACE-OUTPUT* *STANDARD-OUTPUT*) 9 | (setq *STANDARD-INPUT* (make-read-char-exclusive-input-stream)) 10 | (setq *TERMINAL-IO* (MAKE-TWO-WAY-STREAM *STANDARD-INPUT* *STANDARD-OUTPUT*) 11 | *QUERY-IO* *TERMINAL-IO* 12 | *DEBUG-IO* *TERMINAL-IO*) 13 | 14 | (defun batch-repl () 15 | (loop 16 | (FORMAT T "~%~A> " (PACKAGE-NAME *PACKAGE*)) 17 | (dolist (x (emacs-cl-eval-interactively (READ))) 18 | (PPRINT x)))) 19 | -------------------------------------------------------------------------------- /src/cl-characters.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 13, Characters. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | ;;; System Class CHARACTER 9 | ;;; Type BASE-CHAR 10 | ;;; Type STANDARD-CHAR 11 | ;;; Type EXTENDED-CHAR 12 | 13 | (unless use-character-type-p 14 | (define-storage-layout char (code))) 15 | 16 | (defun CHAR= (&rest chars) 17 | (apply #'cl:= (mapcar #'CHAR-CODE chars))) 18 | 19 | (defun CHAR/= (&rest chars) 20 | (apply #'cl:/= (mapcar #'CHAR-CODE chars))) 21 | 22 | (defun CHAR< (&rest chars) 23 | (apply #'cl:< (mapcar #'CHAR-CODE chars))) 24 | 25 | (defun CHAR> (&rest chars) 26 | (apply #'cl:> (mapcar #'CHAR-CODE chars))) 27 | 28 | (defun CHAR<= (&rest chars) 29 | (apply #'cl:<= (mapcar #'CHAR-CODE chars))) 30 | 31 | (defun CHAR>= (&rest chars) 32 | (apply #'cl:>= (mapcar #'CHAR-CODE chars))) 33 | 34 | (defun char-upcase-code (char) 35 | (CHAR-CODE (CHAR-UPCASE char))) 36 | 37 | (defun CHAR-EQUAL (&rest chars) 38 | (apply #'cl:= (mapcar #'char-upcase-code chars))) 39 | 40 | (defun CHAR-NOT-EQUAL (&rest chars) 41 | (apply #'cl:/= (mapcar #'char-upcase-code chars))) 42 | 43 | (defun CHAR-LESSP (&rest chars) 44 | (apply #'cl:< (mapcar #'char-upcase-code chars))) 45 | 46 | (defun CHAR-GREATERP (&rest chars) 47 | (apply #'cl:> (mapcar #'char-upcase-code chars))) 48 | 49 | (defun CHAR-NOT-GREATERP (&rest chars) 50 | (apply #'cl:<= (mapcar #'char-upcase-code chars))) 51 | 52 | (defun CHAR-NOT-LESSP (&rest chars) 53 | (apply #'cl:>= (mapcar #'char-upcase-code chars))) 54 | 55 | (defun CHARACTER (x) 56 | (cond 57 | ((CHARACTERP x) x) 58 | ((and (STRINGP x) (= (LENGTH x) 1)) (AREF x 0)) 59 | ((SYMBOLP x) (CHARACTER (SYMBOL-NAME x))) 60 | (t 61 | (error "invalid character designator")))) 62 | 63 | (if use-character-type-p 64 | (fset 'CHARACTERP (symbol-function 'characterp)) 65 | (defun CHARACTERP (char) 66 | (vector-and-typep char 'CHARACTER))) 67 | 68 | (defun ALPHA-CHAR-P (char) 69 | (or (cl:<= 65 (CHAR-CODE char) 90) 70 | (cl:<= 97 (CHAR-CODE char) 122))) 71 | 72 | (defun ALPHANUMERICP (char) 73 | (or (DIGIT-CHAR-P char) (ALPHA-CHAR-P char))) 74 | 75 | (defun* DIGIT-CHAR (weight &optional (radix 10)) 76 | (when (cl:< weight radix) 77 | (CODE-CHAR (if (< weight 10) 78 | (+ 48 weight) 79 | (+ 65 weight -10))))) 80 | 81 | (defun* DIGIT-CHAR-P (char &optional (radix 10)) 82 | (let* ((code (CHAR-CODE char)) 83 | (n (cond 84 | ((cl:<= 48 code 57) (- code 48)) 85 | ((cl:<= 65 code 90) (- code 65 -10)) 86 | ((cl:<= 95 code 122) (- code 95 -10)) 87 | (t 99)))) 88 | (if (< n radix) n nil))) 89 | 90 | (defun GRAPHIC-CHAR-P (char) 91 | (let ((code (CHAR-CODE char))) 92 | (and (>= code 32) (<= code 126)))) 93 | 94 | (defconst standard-chars 95 | "\n abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~") 96 | 97 | (if use-character-type-p 98 | (defun STANDARD-CHAR-P (char) 99 | (find char standard-chars)) 100 | (defun STANDARD-CHAR-P (char) 101 | (find (CHAR-CODE char) standard-chars))) 102 | 103 | (defun CHAR-UPCASE (char) 104 | (if (LOWER-CASE-P char) 105 | (CODE-CHAR (- (CHAR-CODE char) 32)) 106 | char)) 107 | 108 | (defun CHAR-DOWNCASE (char) 109 | (if (UPPER-CASE-P char) 110 | (CODE-CHAR (+ (CHAR-CODE char) 32)) 111 | char)) 112 | 113 | (defun UPPER-CASE-P (char) 114 | (cl:<= 65 (CHAR-CODE char) 90)) 115 | 116 | (defun LOWER-CASE-P (char) 117 | (cl:<= 97 (CHAR-CODE char) 122)) 118 | 119 | (defun BOTH-CASE-P (char) 120 | (or (UPPER-CASE-P char) (LOWER-CASE-P char))) 121 | 122 | (if use-character-type-p 123 | (fset 'CHAR-CODE (symbol-function 'char-to-int)) 124 | (defun CHAR-CODE (char) 125 | (char-code char))) 126 | 127 | (fset 'CHAR-INT (symbol-function 'CHAR-CODE)) 128 | 129 | (if use-character-type-p 130 | (defun CODE-CHAR (code) 131 | (if (and (integerp code) (< code CHAR-CODE-LIMIT)) 132 | (int-char code) 133 | nil)) 134 | (defun CODE-CHAR (code) 135 | (if (and (integerp code) (< code CHAR-CODE-LIMIT)) 136 | (vector 'CHARACTER code) 137 | nil))) 138 | 139 | (DEFCONSTANT CHAR-CODE-LIMIT 256) 140 | 141 | (defun NAME-CHAR (name) 142 | (let ((string (STRING name))) 143 | (cond 144 | ((equalp string "Backspace") (ch 8)) 145 | ((equalp string "Tab") (ch 9)) 146 | ((equalp string "Newline") (ch 10)) 147 | ((equalp string "Linefeed") (ch 10)) 148 | ((equalp string "Page") (ch 12)) 149 | ((equalp string "Return") (ch 13)) 150 | ((equalp string "Space") (ch 32)) 151 | ((equalp string "Rubout") (ch 127))))) 152 | 153 | (defun CHAR-NAME (char) 154 | (case (CHAR-CODE char) 155 | (8 "Backspace") 156 | (9 "Tab") 157 | (10 "Newline") 158 | (12 "Page") 159 | (13 "Return") 160 | (32 "Space") 161 | (127 "Rubout"))) 162 | -------------------------------------------------------------------------------- /src/cl-evaluation.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 3, Evaluation and Compilation. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | ;;; Assigned later in populate-packages. 9 | (defvar *global-environment* nil) 10 | 11 | (defvar *compiler-macro-functions* (make-hash-table :test 'equal)) 12 | 13 | (defvar *macro-functions* (make-hash-table)) 14 | 15 | (defvar *symbol-macro-functions* (make-hash-table)) 16 | 17 | (defun COMPILER-MACRO-FUNCTION (name &optional env) 18 | (gethash name *compiler-macro-functions*)) 19 | 20 | (defsetf COMPILER-MACRO-FUNCTION (name &optional env) (fn) 21 | `(setf (gethash ,name *compiler-macro-functions*) ,fn)) 22 | 23 | ;; DEFINE-COMPILER-MACRO defined later. 24 | 25 | ;;; Redefined later in cl-eval.el. 26 | (defun lexical-function (name env) 27 | nil) 28 | 29 | (defun MACRO-FUNCTION (name &optional env) 30 | (when (null env) 31 | (setq env *global-environment*)) 32 | (multiple-value-bind (type localp decl) (function-information name env) 33 | (when (eq type :macro) 34 | (if localp 35 | (lexical-function name env) 36 | (gethash name *macro-functions*))))) 37 | 38 | (defsetf MACRO-FUNCTION (name &optional env) (fn) 39 | `(if (null ,env) 40 | (setf (gethash ,name *macro-functions*) ,fn) 41 | (set-local-macro ,name ,fn ,env))) 42 | 43 | (defun make-macro-el-function (name lambda-list body) 44 | (with-gensyms (fvar evar) 45 | (let ((e (memq '&environment lambda-list)) 46 | (form fvar)) 47 | (when e 48 | (when (null (cdr e)) 49 | (ERROR 'PROGRAM-ERROR)) 50 | (setq evar (second e)) 51 | (let ((x lambda-list)) 52 | (while x 53 | (when (eq (cadr x) '&environment) 54 | (setf (cdr x) (cdddr x))) 55 | (setq x (cdr x))))) 56 | (if (eq (first lambda-list) '&whole) 57 | (unless (= (length lambda-list) 2) 58 | (push (gensym) (cddr lambda-list))) 59 | (setq form `(cdr ,fvar))) 60 | (unless (null lambda-list) 61 | (setq body `((destructuring-bind ,lambda-list ,form ,@body)))) 62 | `(lambda (,fvar ,evar) ,@body)))) 63 | 64 | (defmacro* cl:defmacro (name lambda-list &body body) 65 | (when byte-compile-warnings 66 | (byte-compile-log-1 (format "cl:defmacro %s" name))) 67 | `(progn 68 | (unless (fboundp ',name) 69 | (fset ',name nil)) 70 | (setf (MACRO-FUNCTION ',name) 71 | ,(make-macro-el-function name lambda-list body)) 72 | ',name)) 73 | 74 | (cl:defmacro DEFMACRO (name lambda-list &body body) 75 | `(EVAL-WHEN (,(kw COMPILE-TOPLEVEL) ,(kw LOAD-TOPLEVEL) ,(kw EXECUTE)) 76 | (fset (QUOTE ,name) nil) 77 | (SETF (MACRO-FUNCTION (QUOTE ,name)) 78 | ,(make-macro-function name lambda-list body)) 79 | (QUOTE ,name))) 80 | 81 | (cl:defmacro DEFINE-COMPILER-MACRO (name lambda-list &body body) 82 | `(EVAL-WHEN (,(kw COMPILE-TOPLEVEL) ,(kw LOAD-TOPLEVEL) ,(kw EXECUTE)) 83 | (SETF (COMPILER-MACRO-FUNCTION (QUOTE ,name)) 84 | ,(make-macro-function name lambda-list body nil 85 | :type 'COMPILER-MACRO)) 86 | (QUOTE ,name))) 87 | 88 | (cl:defmacro LAMBDA (lambda-list &body body) 89 | `(FUNCTION (LAMBDA ,lambda-list ,@body))) 90 | 91 | ;;; COMPILE is defined in cl-compile.el. 92 | 93 | (defun MACROEXPAND-1 (form &optional env) 94 | (cond 95 | ((and (consp form) 96 | (symbolp (car form))) 97 | (let ((fn (MACRO-FUNCTION (car form) env))) 98 | (if fn 99 | (let ((new (FUNCALL *MACROEXPAND-HOOK* fn form env))) 100 | (cl:values new (not (eq form new)))) 101 | (cl:values form nil)))) 102 | ((symbolp form) 103 | (multiple-value-bind (type localp decls) (variable-information form env) 104 | (if (eq type :symbol-macro) 105 | (if localp 106 | (let ((fn (lexical-value form env))) 107 | (cl:values (funcall *MACROEXPAND-HOOK* fn form env) T)) 108 | (let ((fn (gethash form *symbol-macro-functions*))) 109 | (if fn 110 | (cl:values (funcall *MACROEXPAND-HOOK* fn form env) T) 111 | (cl:values form nil)))) 112 | (cl:values form nil)))) 113 | (t 114 | (cl:values form nil)))) 115 | 116 | (defun* MACROEXPAND (form &optional env) 117 | (let ((form form) (expanded-p nil) exp) 118 | (loop 119 | (MULTIPLE-VALUE-SETQ (form exp) (MACROEXPAND-1 form env)) 120 | (if exp 121 | (setq expanded-p T) 122 | (return-from MACROEXPAND (cl:values form expanded-p)))))) 123 | 124 | (defmacro* DEFINE-SYMBOL-MACRO (symbol expansion) 125 | `(eval-when (:compile-toplevel :load-toplevel :execute) 126 | (setf (gethash ',symbol *symbol-macro-functions*) 127 | (cl:lambda (form env) ',expansion)) 128 | ',symbol)) 129 | 130 | (cl:defmacro DEFINE-SYMBOL-MACRO (symbol expansion) 131 | `(EVAL-WHEN (,(kw COMPILE-TOPLEVEL) ,(kw LOAD-TOPLEVEL) ,(kw EXECUTE)) 132 | (puthash (QUOTE ,symbol) (LAMBDA (form env) (QUOTE ,expansion)) 133 | *symbol-macro-functions*) 134 | (QUOTE ,symbol))) 135 | 136 | (defvar *MACROEXPAND-HOOK* 'FUNCALL) 137 | 138 | (defvar *declarations* 139 | '(IGNORE IGNORABLE DYNAMIC-EXTENT TYPE INLINE 140 | NOTINLINE FTYPE DECLARATION OPTIMIZE SPECIAL 141 | ;; Emacs Common Lisp extensions: 142 | INTERACTIVE) 143 | "A list of valid declaration identifiers.") 144 | 145 | (defun valid-declaration-identifier-p (object) 146 | (or (memq object *declarations*) 147 | (gethash object *atomic-typespecs*) 148 | (gethash object *deftype-expanders*) 149 | (classp object))) 150 | 151 | (defun PROCLAIM (declaration) 152 | (unless (and (consp declaration) 153 | (valid-declaration-identifier-p (car declaration))) 154 | (type-error declaration `(CONS (MEMBER ,@*declarations*) LIST))) 155 | (case (first declaration) 156 | (SPECIAL 157 | (dolist (var (rest declaration)) 158 | (pushnew var *specials*))) 159 | (INLINE) 160 | (NOTINLINE) 161 | (DECLARATION 162 | (dolist (name (rest declaration)) 163 | (pushnew name *declarations*)))) 164 | nil) 165 | 166 | (cl:defmacro DECLAIM (&rest declarations) 167 | `(EVAL-WHEN (,(kw COMPILE-TOPLEVEL) ,(kw LOAD-TOPLEVEL) ,(kw EXECUTE)) 168 | ,@(mapcar (lambda (decl) `(PROCLAIM (QUOTE ,decl))) 169 | declarations))) 170 | 171 | ;;; THE setf expansion defined in cl-flow.el. 172 | 173 | (defun SPECIAL-OPERATOR-P (symbol) 174 | (unless (symbolp symbol) 175 | (type-error symbol 'SYMBOL)) 176 | (memq symbol 177 | '(BLOCK CATCH EVAL-WHEN FLET FUNCTION GO IF LABELS LET LET* 178 | LOAD-TIME-VALUE LOCALLY MACROLET MULTIPLE-VALUE-CALL 179 | MULTIPLE-VALUE-PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ 180 | SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT))) 181 | 182 | (defun quoted-object-p (object) 183 | (and (consp object) 184 | (eq (car object) 'QUOTE))) 185 | 186 | (defun CONSTANTP (object &optional env) 187 | (unless env 188 | (setq env *global-environment*)) 189 | (cond 190 | ((KEYWORDP object)) 191 | ((symbolp object) 192 | (memq object *constants*)) 193 | ((atom object)) 194 | ((quoted-object-p object)))) 195 | -------------------------------------------------------------------------------- /src/cl-files.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 20, Files. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | (defun file-error (pathname) 9 | (ERROR 'FILE-ERROR (kw PATHNAME) pathname)) 10 | 11 | (defun wild-directories (name dir pathname files) 12 | (if (null dir) 13 | (nconc (DIRECTORY (MERGE-PATHNAMES name pathname)) files) 14 | (let ((component (first dir))) 15 | (setq dir (rest dir)) 16 | (cond 17 | ((eq component (kw WILD)) 18 | (dolist (file (directory-files name) files) 19 | (unless (or (string= file ".") (string= file "..")) 20 | (setq file (concat name file "/")) 21 | (when (file-directory-p file) 22 | (setq files (wild-directories file dir pathname files)))))) 23 | ((eq component (kw WILD-INFERIORS)) 24 | (setq files (wild-directories name dir pathname files)) 25 | (dolist (file (directory-files name) files) 26 | (unless (or (string= file ".") (string= file "..")) 27 | (setq file (concat name file "/")) 28 | (when (file-directory-p file) 29 | (setq files (wild-directories 30 | file (cons (kw WILD-INFERIORS) dir) 31 | pathname files)))))) 32 | ((eq component (kw UP)) 33 | (wild-directories (concat name "../") dir pathname files)) 34 | ((eq component (kw BACK)) 35 | (ERROR ":BACK isn't supported")) 36 | (t 37 | (let ((file (concat name component "/"))) 38 | (if (file-directory-p file) 39 | (wild-directories file dir pathname files) 40 | files))))))) 41 | 42 | (defun DIRECTORY (pathname-designator) 43 | (let ((pathname (MERGE-PATHNAMES pathname-designator))) 44 | (if (WILD-PATHNAME-P pathname (kw DIRECTORY)) 45 | (let* ((dir (PATHNAME-DIRECTORY pathname)) 46 | (x (pop dir)) 47 | (name (cond 48 | ((eq x (kw ABSOLUTE)) "/") 49 | ((or (null x) (eq x (kw RELATIVE))) "./") 50 | (t (error "error"))))) 51 | (wild-directories name dir pathname nil)) 52 | (let ((result nil) 53 | (dir (MAKE-PATHNAME (kw DIRECTORY) 54 | (PATHNAME-DIRECTORY pathname)))) 55 | (dolist (file (directory-files (DIRECTORY-NAMESTRING pathname))) 56 | (setq file (MERGE-PATHNAMES file dir)) 57 | (when (PATHNAME-MATCH-P file pathname) 58 | (push file result))) 59 | result)))) 60 | 61 | (defun PROBE-FILE (pathname-designator) 62 | (let ((pathname (MERGE-PATHNAMES pathname-designator))) 63 | (when (file-exists-p (NAMESTRING pathname)) 64 | (TRUENAME pathname)))) 65 | 66 | (cl:defun ENSURE-DIRECTORIES-EXIST (pathname-designator &KEY VERBOSE) 67 | (let* ((pathname (MERGE-PATHNAMES pathname-designator)) 68 | (dir (DIRECTORY-NAMESTRING pathname))) 69 | (when (or (eq (PATHNAME-HOST pathname) (kw WILD)) 70 | (eq (PATHNAME-DEVICE pathname) (kw WILD)) 71 | (or (memq (kw WILD) (PATHNAME-DIRECTORY pathname)) 72 | (memq (kw WILD-INFERIORS) (PATHNAME-DIRECTORY pathname)))) 73 | (ERROR 'FILE-ERROR)) 74 | (cl:values pathname-designator 75 | (unless (file-exists-p dir) 76 | (make-directory dir t) 77 | T)))) 78 | 79 | (defun TRUENAME (pathname-designator) 80 | (let ((pathname (MERGE-PATHNAMES pathname-designator))) 81 | (PATHNAME (file-truename (NAMESTRING pathname))))) 82 | 83 | (defun FILE-AUTHOR (pathname-designator) 84 | (let ((pathname (MERGE-PATHNAMES pathname-designator))) 85 | (user-login-name (nth 2 (file-attributes (NAMESTRING pathname)))))) 86 | 87 | (defun FILE-WRITE-DATE (pathname-designator) 88 | (let* ((pathname (MERGE-PATHNAMES pathname-designator)) 89 | (filename (NAMESTRING pathname)) 90 | (x (nth 5 (file-attributes filename))) 91 | (y (first x)) 92 | (z (second x))) 93 | (when (null x) 94 | (file-error pathname)) 95 | (cl:+ (binary* y 65536) z universal-time-offset))) 96 | 97 | (defun RENAME-FILE (old-pathname-designator new-pathname-designator) 98 | (let* ((old-pathname (MERGE-PATHNAMES old-pathname-designator)) 99 | (new-pathname (MERGE-PATHNAMES new-pathname-designator old-pathname))) 100 | (rename-file (NAMESTRING old-pathname) (NAMESTRING new-pathname) t) 101 | (cl:values new-pathname (TRUENAME old-pathname) (TRUENAME new-pathname)))) 102 | 103 | (defun DELETE-FILE (pathname-designator) 104 | (let* ((pathname (MERGE-PATHNAMES pathname-designator)) 105 | (filename (NAMESTRING pathname))) 106 | (if (file-exists-p filename) 107 | (delete-file filename) 108 | (file-error pathname)) 109 | T)) 110 | 111 | ;;; FILE-ERROR and FILE-ERROR-PATHNAME are defined in cl-conditions.el. 112 | -------------------------------------------------------------------------------- /src/cl-hash.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 18, Hash Tables. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | (if (eval-when-compile (eq (type-of (make-hash-table)) 'hash-table)) 9 | (progn 10 | (cl:defun MAKE-HASH-TABLE (&KEY TEST (SIZE 10) REHASH-SIZE 11 | REHASH-THRESHOLD) 12 | (make-hash-table :test (el-test TEST) :size SIZE)) 13 | 14 | (when (eval-when-compile (fboundp 'define-hash-table-test)) 15 | (define-hash-table-test 'EQL #'EQL #'sxhash) 16 | (define-hash-table-test 'EQUAL #'EQUAL #'sxhash) 17 | (define-hash-table-test 'EQUALP #'EQUALP #'equalp-hash) 18 | 19 | (defun equalp-hash (object) 20 | (cond 21 | ((CHARACTERP object) (sxhash (CHAR-UPCASE object))) 22 | ((REALP object) (sxhash (FLOAT object))) 23 | ((NUMBERP object) (+ (sxhash (FLOAT (REALPART object))) 24 | (sxhash (FLOAT (IMAGPART object))))) 25 | ((consp object) (+ (equalp-hash (car object)) 26 | (equalp-hash (cdr object)))) 27 | ((STRINGP object) (sxhash (STRING-UPCASE object))) 28 | (t (ERROR "TODO: equalp-hash"))))) 29 | 30 | (defun el-test (fn) 31 | (cond 32 | ((null fn) 'EQL) 33 | ((eq fn 'EQ) 'eq) 34 | ((eq fn (symbol-function 'EQ)) 'eq) 35 | ((eq fn 'EQL) 'EQL) 36 | ((eq fn (symbol-function 'EQL)) 'EQL) 37 | ((eq fn 'EQUAL) 'EQUAL) 38 | ((eq fn (symbol-function 'EQUAL)) 'EQUAL) 39 | ((eq fn 'EQUALP) 'EQUALP) 40 | ((eq fn (symbol-function 'EQUALP)) 'EQUALP) 41 | (t 42 | (ERROR "Unknown hash table test function")))) 43 | 44 | (defmacro htab (hash) 45 | hash) 46 | 47 | (cl:defmacro HTAB (hash) 48 | hash) 49 | 50 | (defun HASH-TABLE-P (object) 51 | (hash-table-p object)) 52 | 53 | (defun HASH-TABLE-TEST (hash) 54 | (hash-table-test hash))) 55 | 56 | ;; If there isn't a real hash-table type, make one using defstruct. 57 | (progn 58 | (DEFSTRUCT (HASH-TABLE (:copier nil) (:constructor mkhash (TABLE TEST))) 59 | TABLE TEST) 60 | 61 | (cl:defun MAKE-HASH-TABLE (&KEY (TEST #'EQL) (SIZE 10) REHASH-SIZE 62 | REHASH-THRESHOLD) 63 | (mkhash (make-hash-table :test TEST :size SIZE) TEST)) 64 | 65 | (defun htab (hash) 66 | (HASH-TABLE-TABLE hash)) 67 | 68 | (cl:defmacro HTAB (hash) 69 | `(HASH-TABLE-TABLE ,hash)))) 70 | 71 | (defun HASH-TABLE-COUNT (hash) 72 | (hash-table-count (htab hash))) 73 | 74 | (defun HASH-TABLE-REHASH-SIZE (hash) 75 | ;; TODO 76 | 0) 77 | 78 | (defun HASH-TABLE-REHASH-THRESHOLD (hash) 79 | ;; TODO 80 | 0) 81 | 82 | (defun HASH-TABLE-SIZE (hash) 83 | ;; TODO 84 | 0) 85 | 86 | (defun GETHASH (key hash &optional default) 87 | (let ((object (gethash key (htab hash) not-found))) 88 | (if (eq object not-found) 89 | (cl:values default nil) 90 | (cl:values object T)))) 91 | 92 | (DEFINE-SETF-EXPANDER GETHASH (key hash &optional default) 93 | (with-gensyms (keytemp hashtemp val) 94 | (cl:values (list keytemp hashtemp) 95 | (list key hash) 96 | (list val) 97 | `(puthash ,keytemp ,val (HTAB ,hashtemp)) 98 | `(GETHASH ,keytemp ,hashtemp)))) 99 | 100 | (defun REMHASH (key hash) 101 | (remhash key (htab hash))) 102 | 103 | (defun MAPHASH (fn hash) 104 | (maphash (el-function fn) (htab hash)) 105 | nil) 106 | 107 | (defun hashlist (hash) 108 | (let ((list nil)) 109 | (maphash (lambda (k v) (push (cons k v) list)) hash) 110 | list)) 111 | 112 | (cl:defmacro WITH-HASH-TABLE-ITERATOR ((name hash) &body body) 113 | (with-gensyms (list) 114 | `(LET ((,list (hashlist ,hash))) 115 | (MACROLET ((,name () 116 | (QUOTE (IF (NULL ,list) (cl:values nil nil nil) 117 | (LET ((cons (POP ,list))) 118 | (cl:values T (CAR cons) (CDR cons))))))) 119 | ,@body)))) 120 | 121 | (defun CLRHASH (hash) 122 | (clrhash (htab hash)) 123 | hash) 124 | 125 | (if (eval-when-compile (fboundp 'sxhash)) 126 | (fset 'SXHASH (symbol-function 'sxhash)) 127 | (defun SXHASH (object) 42)) 128 | -------------------------------------------------------------------------------- /src/cl-iteration.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 6, Iteration. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | (defun var-inits (vars) 9 | (mapcar (lambda (var) 10 | (if (symbolp var) 11 | var 12 | `(,(first var) ,(second var)))) 13 | vars)) 14 | 15 | (defun var-steps (vars) 16 | (mappend (lambda (var) 17 | (when (and (consp var) (= (length var) 3)) 18 | `(,(first var) ,(third var)))) 19 | vars)) 20 | 21 | (defun expand-do (let setq vars test result forms) 22 | (with-gensyms (start) 23 | (MULTIPLE-VALUE-BIND (body decls) (parse-body forms) 24 | (let ((block `(TAGBODY 25 | ,start 26 | ,@(when test `((WHEN ,test (RETURN (PROGN ,@result))))) 27 | ,@(if decls 28 | `((LOCALLY (DECLARE ,@decls) ,@body)) 29 | body) 30 | ,@(when vars `((,setq ,@(var-steps vars)))) 31 | (GO ,start)))) 32 | `(BLOCK nil 33 | ,(cond 34 | (vars `(,let ,(var-inits vars) 35 | ,@(when decls `((DECLARE ,@decls))) ,block)) 36 | (decls `(LOCALLY (DECLARE ,@decls) ,block)) 37 | (t block))))))) 38 | 39 | (cl:defmacro DO (vars (test &rest result) &body body) 40 | (expand-do 'LET 'PSETQ vars test result body)) 41 | 42 | (cl:defmacro DO* (vars (test &rest result) &body body) 43 | (expand-do 'LET* 'SETQ vars test result body)) 44 | 45 | (cl:defmacro DOTIMES ((var count &optional result) &body body) 46 | (with-gensyms (end) 47 | `(DO ((,var 0 (,(INTERN "1+" "CL") ,var)) 48 | (,end ,count)) 49 | ((,(INTERN ">=" *cl-package*) ,var ,end) 50 | (LET ((,var (MAX ,count 0))) 51 | ,result)) 52 | ,@body))) 53 | 54 | (cl:defmacro DOLIST ((var list &optional result) &body forms) 55 | (with-gensyms (glist) 56 | (MULTIPLE-VALUE-BIND (body decls) (parse-body forms) 57 | `(DO (,var 58 | (,glist ,list (CDR ,glist))) 59 | ((NULL ,glist) 60 | (LET ((,var nil)) 61 | ,result)) 62 | (DECLARE ,@decls) 63 | (SETQ ,var (CAR ,glist)) 64 | ,@body)))) 65 | 66 | ;;; LOOP and LOOP-FINISH are implemented in cl-loop.el. 67 | -------------------------------------------------------------------------------- /src/cl-strings.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 16, Strings. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | ;;; System Class STRING 9 | 10 | ;;; Type BASE-STRING 11 | 12 | ;;; Type SIMPLE-STRING 13 | 14 | ;;; Type SIMPLE-BASE-STRING 15 | 16 | (defun SIMPLE-STRING-P (object) 17 | (stringp object)) 18 | 19 | (defun CHAR (string index) 20 | (cond 21 | ((SIMPLE-STRING-P string) 22 | (SCHAR string index)) 23 | ((STRINGP string) 24 | (SCHAR (aref string 2) index)) 25 | (t 26 | (type-error string 'STRING)))) 27 | 28 | (defsetf CHAR (string index) (char) 29 | `(cond 30 | ((SIMPLE-STRING-P ,string) 31 | (setf (SCHAR ,string ,index) ,char)) 32 | ((STRINGP ,string) 33 | (setf (SCHAR (aref ,string 2) ,index) ,char)) 34 | (t 35 | (type-error ,string 'STRING)))) 36 | 37 | (DEFINE-SETF-EXPANDER CHAR (string index) 38 | (let ((obj (gensym)) 39 | (stemp (gensym)) 40 | (itemp (gensym))) 41 | (cl:values (list stemp itemp) 42 | (list string index) 43 | (list obj) 44 | `(SET-CHAR ,obj ,stemp ,itemp) 45 | `(CHAR ,stemp ,itemp)))) 46 | 47 | (defun SET-CHAR (char string index) 48 | (cond 49 | ((SIMPLE-STRING-P string) 50 | (SET-SCHAR char string index)) 51 | ((STRINGP string) 52 | (SET-SCHAR char (aref string 2) index)) 53 | (t 54 | (type-error string 'STRING)))) 55 | 56 | (if use-character-type-p 57 | (defun SCHAR (string index) 58 | (aref string index)) 59 | (defun SCHAR (string index) 60 | (CODE-CHAR (aref string index)))) 61 | 62 | (if use-character-type-p 63 | (defsetf SCHAR (string index) (char) 64 | `(aset ,string ,index ,char)) 65 | (defsetf SCHAR (string index) (char) 66 | (let ((temp (gensym))) 67 | `(let ((,temp ,char)) 68 | (aset ,string ,index (CHAR-CODE ,temp)) 69 | ,temp)))) 70 | 71 | 72 | (DEFINE-SETF-EXPANDER SCHAR (string index) 73 | (let ((obj (gensym)) 74 | (stemp (gensym)) 75 | (itemp (gensym))) 76 | (cl:values (list stemp itemp) 77 | (list string index) 78 | (list obj) 79 | `(SET-SCHAR ,obj ,stemp ,itemp) 80 | `(SCHAR ,stemp ,itemp)))) 81 | 82 | (if use-character-type-p 83 | (defun SET-SCHAR (char string index) 84 | (aset string index char)) 85 | (defun SET-SCHAR (char string index) 86 | (aset string index (CHAR-CODE char)) 87 | char)) 88 | 89 | (defun STRING (x) 90 | (cond 91 | ((STRINGP x) x) 92 | ((SYMBOLP x) (SYMBOL-NAME x)) 93 | ((CHARACTERP x) (MAKE-STRING 1 (kw INITIAL-ELEMENT) x)) 94 | (t (type-error x '(OR STRING SYMBOL CHARACTER))))) 95 | 96 | (cl:defun STRING-UPCASE (string &KEY (START 0) END) 97 | (NSTRING-UPCASE (COPY-SEQ (STRING string)) (kw START) START (kw END) END)) 98 | 99 | (cl:defun STRING-DOWNCASE (string &KEY (START 0) END) 100 | (NSTRING-DOWNCASE (COPY-SEQ (STRING string)) (kw START) START (kw END) END)) 101 | 102 | (cl:defun STRING-CAPITALIZE (string &KEY (START 0) (END (LENGTH string))) 103 | (NSTRING-CAPITALIZE (COPY-SEQ (STRING string)) 104 | (kw START) START (kw END) END)) 105 | 106 | (cl:defun NSTRING-UPCASE (string &KEY (START 0) END) 107 | (setq string (STRING string)) 108 | (unless END 109 | (setq END (LENGTH string))) 110 | (do ((i START (1+ i))) 111 | ((eq i END) string) 112 | (setf (CHAR string i) (CHAR-UPCASE (CHAR string i))))) 113 | 114 | (cl:defun NSTRING-DOWNCASE (string &KEY (START 0) END) 115 | (setq string (STRING string)) 116 | (unless END 117 | (setq END (LENGTH string))) 118 | (do ((i START (1+ i))) 119 | ((eq i END) string) 120 | (setf (CHAR string i) (CHAR-DOWNCASE (CHAR string i))))) 121 | 122 | (cl:defun NSTRING-CAPITALIZE (string &KEY (START 0) (END (LENGTH string))) 123 | (setq string (STRING string)) 124 | (do* ((i START (1+ i)) 125 | (in-word-p nil)) 126 | ((eq i END) 127 | string) 128 | (let* ((char (CHAR string i)) 129 | (alnump (ALPHANUMERICP char))) 130 | (when alnump 131 | (setf (CHAR string i) 132 | (if in-word-p (CHAR-DOWNCASE char) (CHAR-UPCASE char)))) 133 | (setq in-word-p alnump)))) 134 | 135 | (defun STRING-TRIM (chars string) 136 | (STRING-LEFT-TRIM chars (STRING-RIGHT-TRIM chars string))) 137 | 138 | (defun STRING-LEFT-TRIM (chars string) 139 | (setq string (STRING string)) 140 | (let ((i 0) 141 | (len (LENGTH string))) 142 | (while (and (< i len) (FIND (CHAR string i) chars)) 143 | (incf i)) 144 | (SUBSEQ string i))) 145 | 146 | (defun STRING-RIGHT-TRIM (chars string) 147 | (setq string (STRING string)) 148 | (let* ((i (1- (LENGTH string)))) 149 | (while (and (>= i 0) (FIND (CHAR string i) chars)) 150 | (decf i)) 151 | (SUBSEQ string 0 (1+ i)))) 152 | 153 | (cl:defun STRING= (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 154 | (setq string1 (STRING string1)) 155 | (setq string2 (STRING string2)) 156 | (string= (substring string1 START1 END1) 157 | (substring string2 START2 END2))) 158 | 159 | (cl:defun STRING/= (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 160 | (not (STRING= string1 string2 (kw START1) START1 (kw END1) END1 161 | (kw START2) START2 (kw END2) END2))) 162 | 163 | (defun cl-string-cmp (string1 string2) 164 | (let ((len1 (LENGTH string1)) 165 | (len2 (LENGTH string2)) 166 | (i 0)) 167 | (loop 168 | (when (= i len1) 169 | (return (cl:values i (if (= i len2) 0 -1)))) 170 | (when (= i len2) 171 | (return (cl:values i 1))) 172 | (let ((c1 (CHAR string1 i)) 173 | (c2 (CHAR string2 i))) 174 | (cond 175 | ((CHAR< c1 c2) (return (cl:values i -1))) 176 | ((CHAR> c1 c2) (return (cl:values i 1))) 177 | (t (incf i))))))) 178 | 179 | (cl:defun STRING< (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 180 | (MULTIPLE-VALUE-BIND (index cmp) 181 | (cl-string-cmp (SUBSEQ (STRING string1) START1 END1) 182 | (SUBSEQ (STRING string2) START2 END2)) 183 | (when (minusp cmp) 184 | index))) 185 | 186 | (cl:defun STRING> (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 187 | (MULTIPLE-VALUE-BIND (index cmp) 188 | (cl-string-cmp (SUBSEQ (STRING string1) START1 END1) 189 | (SUBSEQ (STRING string2) START2 END2)) 190 | (when (plusp cmp) 191 | index))) 192 | 193 | (cl:defun STRING<= (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 194 | (MULTIPLE-VALUE-BIND (index cmp) 195 | (cl-string-cmp (SUBSEQ (STRING string1) START1 END1) 196 | (SUBSEQ (STRING string2) START2 END2)) 197 | (when (not (plusp cmp)) 198 | index))) 199 | 200 | (cl:defun STRING>= (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 201 | (MULTIPLE-VALUE-BIND (index cmp) 202 | (cl-string-cmp (SUBSEQ (STRING string1) START1 END1) 203 | (SUBSEQ (STRING string2) START2 END2)) 204 | (when (not (minusp cmp)) 205 | index))) 206 | 207 | (cl:defun STRING-EQUAL (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 208 | (string= (substring (STRING-UPCASE string1) START1 END1) 209 | (substring (STRING-UPCASE string2) START2 END2))) 210 | 211 | (cl:defun STRING-NOT-EQUAL (string1 string2 &KEY (START1 0) END1 212 | (START2 0) END2) 213 | (not (STRING-EQUAL string1 string2 (kw START1) START1 (kw END1) END1 214 | (kw START2) START2 (kw END2) END2))) 215 | 216 | (cl:defun STRING-LESSP (string1 string2 &KEY (START1 0) END1 (START2 0) END2) 217 | (STRING< (substring (STRING-UPCASE string1) START1 END1) 218 | (substring (STRING-UPCASE string2) START1 END1))) 219 | 220 | (cl:defun STRING-GREATERP (string1 string2 &KEY (START1 0) END1 221 | (START2 0) END2) 222 | (STRING> (substring (STRING-UPCASE string1) START1 END1) 223 | (substring (STRING-UPCASE string2) START1 END1))) 224 | 225 | (cl:defun STRING-NOT-GREATERP (string1 string2 &KEY (START1 0) END1 226 | (START2 0) END2) 227 | (STRING<= (substring (STRING-UPCASE string1) START1 END1) 228 | (substring (STRING-UPCASE string2) START1 END1))) 229 | 230 | (cl:defun STRING-NOT-LESSP (string1 string2 &KEY (START1 0) END1 231 | (START2 0) END2) 232 | (STRING>= (substring (STRING-UPCASE string1) START1 END1) 233 | (substring (STRING-UPCASE string2) START1 END1))) 234 | 235 | (defun STRINGP (object) 236 | (or (stringp object) 237 | (vector-and-typep object 'STRING))) 238 | 239 | (if use-character-type-p 240 | (cl:defun MAKE-STRING (size &KEY INITIAL-ELEMENT ELEMENT-TYPE) 241 | (make-string size (or INITIAL-ELEMENT ?\000))) 242 | (cl:defun MAKE-STRING (size &KEY INITIAL-ELEMENT ELEMENT-TYPE) 243 | (make-string size (if INITIAL-ELEMENT (CHAR-CODE INITIAL-ELEMENT) 0)))) 244 | -------------------------------------------------------------------------------- /src/cl-symbols.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 10, Symbols. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | ;;; Note that the Emacs Lisp symbol nil doubles as the Common Lisp 9 | ;;; symbol NIL. This requires special attention in SYMBOL-NAME. 10 | 11 | ;;; The SYMBOL system class is built in. 12 | 13 | (fset 'SYMBOLP (symbol-function 'symbolp)) 14 | 15 | (defun KEYWORDP (sym) 16 | (and (SYMBOLP sym) 17 | (eq (SYMBOL-PACKAGE sym) *keyword-package*))) 18 | 19 | (defun MAKE-SYMBOL (string) 20 | (unless (STRINGP string) 21 | (type-error string 'STRING)) 22 | (make-symbol string)) 23 | 24 | (defun COPY-SYMBOL (sym &optional copy-properties) 25 | (let ((new (make-symbol (SYMBOL-NAME sym)))) 26 | (when copy-properties 27 | (when (boundp sym) 28 | (setf (symbol-value new) (symbol-value sym))) 29 | (when (fboundp sym) 30 | (setf (symbol-function new) (symbol-function sym))) 31 | (setf (symbol-plist new) (copy-list (symbol-plist sym)))) 32 | new)) 33 | 34 | (cl:defun GENSYM (&OPTIONAL (x "G")) 35 | (multiple-value-bind (prefix suffix) 36 | (cond 37 | ((STRINGP x) (values x (prog1 *GENSYM-COUNTER* 38 | (setq *GENSYM-COUNTER* 39 | (binary+ *GENSYM-COUNTER* 1))))) 40 | ((INTEGERP x) (values "G" x)) 41 | (t (type-error x '(OR STRING INTEGER)))) 42 | (MAKE-SYMBOL (FORMAT nil "~A~D" prefix suffix)))) 43 | 44 | (DEFVAR *GENSYM-COUNTER* 1) 45 | 46 | (defvar *gentemp-counter* 1) 47 | 48 | (cl:defun GENTEMP (&OPTIONAL (prefix "T") (package *PACKAGE*)) 49 | (catch 'GENTEMP 50 | (loop 51 | (MULTIPLE-VALUE-BIND (symbol found) 52 | (INTERN (FORMAT nil "~A~D" prefix *gentemp-counter*) package) 53 | (unless found 54 | (throw 'GENTEMP (cl:values symbol))) 55 | (incf *gentemp-counter*))))) 56 | 57 | ; (defun SYMBOL-FUNCTION (symbol) 58 | ; (unless (symbolp symbol) 59 | ; (type-error symbol 'SYMBOL)) 60 | ; (unless (fboundp symbol) 61 | ; (ERROR 'UNDEFINED-FUNCTION (kw NAME) symbol)) 62 | ; (symbol-function symbol)) 63 | 64 | ; (DEFSETF SYMBOL-FUNCTION (symbol) (fn) 65 | ; `(fset ,symbol ,fn)) 66 | 67 | (defun SYMBOL-FUNCTION (symbol) 68 | (unless (symbolp symbol) 69 | (type-error symbol 'SYMBOL)) 70 | (unless (fboundp symbol) 71 | (ERROR 'UNDEFINED-FUNCTION (kw NAME) symbol)) 72 | (let ((fn (symbol-function symbol))) 73 | (cond 74 | ((and (consp fn) 75 | (eq (car fn) 'macro)) 76 | nil) 77 | ((and (consp fn) 78 | (consp (third fn)) 79 | (eq (first (third fn)) 'APPLY)) 80 | (let ((ifn (second (third fn)))) 81 | (if (INTERPRETED-FUNCTION-P ifn) ifn fn))) 82 | ((and (consp fn) 83 | (consp (fourth fn)) 84 | (eq (first (fourth fn)) 'APPLY)) 85 | (let ((ifn (second (fourth fn)))) 86 | (if (INTERPRETED-FUNCTION-P ifn) ifn fn))) 87 | (t fn)))) 88 | 89 | (defsetf SYMBOL-FUNCTION set-symbol-function) 90 | 91 | (DEFSETF SYMBOL-FUNCTION set-symbol-function) 92 | 93 | (defun interactive-stuff (forms) 94 | (some (lambda (form) 95 | (and (consp form) 96 | (eq (car form) 'DECLARE) 97 | (consp (cdr form)) 98 | (or (when (eq (cadr form) 'INTERACTIVE) 99 | '((interactive))) 100 | (when (and (consp (cadr form)) 101 | (eq (caadr form) 'INTERACTIVE)) 102 | `((interactive ,@(cdadr form))))))) 103 | forms)) 104 | 105 | (defun el-function (fn) 106 | (if (vectorp fn) 107 | `(lambda (&rest args) 108 | ,@(interactive-stuff 109 | (cddr (cl:values (FUNCTION-LAMBDA-EXPRESSION fn)))) 110 | (APPLY ,fn args)) 111 | fn)) 112 | 113 | (defun set-symbol-function (symbol fn) 114 | (fset symbol 115 | (cond 116 | ((INTERPRETED-FUNCTION-P fn) (el-function fn)) 117 | ((FUNCTIONP fn) fn) 118 | (t (type-error fn 'FUNCTION))))) 119 | 120 | (defun SYMBOL-NAME (symbol) 121 | (if symbol 122 | (symbol-name symbol) 123 | "NIL")) 124 | 125 | (defvar *symbol-package-table* (make-hash-table :test 'eq :weakness t)) 126 | 127 | (defun SYMBOL-PACKAGE (sym) 128 | (or (gethash sym *symbol-package-table*) 129 | (when (interned-p sym) *emacs-lisp-package*))) 130 | 131 | (defsetf SYMBOL-PACKAGE (sym) (package) 132 | `(if (null ,package) 133 | (progn (remhash ,sym *symbol-package-table*) ,package) 134 | (setf (gethash ,sym *symbol-package-table*) ,package))) 135 | 136 | (fset 'SYMBOL-PLIST (symbol-function 'symbol-plist)) 137 | 138 | (DEFSETF SYMBOL-PLIST (symbol) (plist) 139 | `(setplist ,symbol ,plist)) 140 | 141 | (fset 'SYMBOL-VALUE (symbol-function 'symbol-value)) 142 | 143 | (defsetf SYMBOL-VALUE (symbol) (val) 144 | `(set ,symbol ,val)) 145 | 146 | (DEFSETF SYMBOL-VALUE (symbol) (val) 147 | `(SET ,symbol ,val)) 148 | 149 | (defun GET (symbol property &optional default) 150 | (let ((val (member property (symbol-plist symbol)))) 151 | (if val 152 | (cadr val) 153 | default))) 154 | 155 | (DEFSETF GET (symbol property &optional default) (val) 156 | `(put ,symbol ,property ,val)) 157 | 158 | (defun REMPROP (symbol indicator) 159 | (setplist symbol (delete-property (symbol-plist symbol) indicator))) 160 | 161 | (defun BOUNDP (symbol) 162 | (unless (symbolp symbol) 163 | (type-error symbol 'SYMBOL)) 164 | (boundp symbol)) 165 | 166 | (defun MAKUNBOUND (symbol) 167 | (unless (symbolp symbol) 168 | (type-error symbol 'SYMBOL)) 169 | (makunbound symbol)) 170 | 171 | (fset 'SET (symbol-function 'set)) 172 | 173 | ;;; UNBOUND-VARIABLE in cl-conditions.el. 174 | -------------------------------------------------------------------------------- /src/cl-system.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 24, System Construction. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | ;;; COMPILE-FILE is defined in cl-compile.el. 9 | 10 | (defun elc-file (filename) 11 | (MERGE-PATHNAMES (MAKE-PATHNAME (kw TYPE) "elc") filename)) 12 | 13 | (cl:defun COMPILE-FILE-PATHNAME (input-file 14 | &KEY (OUTPUT-FILE (elc-file input-file)) 15 | &ALLOW-OTHER-KEYS) 16 | (let* ((input (MERGE-PATHNAMES input-file))) 17 | (MERGE-PATHNAMES OUTPUT-FILE input))) 18 | 19 | (defun file-has-elc-magic-p (pathname) 20 | (WITH-OPEN-FILE (stream pathname) 21 | (let ((magic (make-string 4 0))) 22 | (and (eq (READ-SEQUENCE magic stream) 4) 23 | (STRING= magic ";ELC"))))) 24 | 25 | (cl:defun LOAD (file &KEY (VERBOSE *LOAD-VERBOSE*) 26 | (PRINT *LOAD-PRINT*) 27 | (IF-DOES-NOT-EXIST T) 28 | (EXTERNAL-FORMAT (kw DEFAULT))) 29 | (let* ((*PACKAGE* *PACKAGE*) 30 | (*READTABLE* *READTABLE*) 31 | (*LOAD-PATHNAME* (MERGE-PATHNAMES file)) 32 | (*LOAD-TRUENAME* (TRUENAME *LOAD-PATHNAME*))) 33 | (cond 34 | ((STREAMP file) 35 | (let ((eof (gensym))) 36 | (do ((form (READ file nil eof) (READ file nil eof))) 37 | ((eq form eof) 38 | (cl:values T)) 39 | (let ((val (EVAL form))) 40 | (when PRINT 41 | (PRINT val)))))) 42 | ((or (STRINGP file) (PATHNAMEP file)) 43 | (when VERBOSE 44 | (FORMAT T "~&;Loading ~A" (NAMESTRING *LOAD-PATHNAME*))) 45 | (if (or (STRING= (PATHNAME-TYPE *LOAD-PATHNAME*) "elc") 46 | (file-has-elc-magic-p *LOAD-PATHNAME*)) 47 | (load (NAMESTRING *LOAD-PATHNAME*)) 48 | (WITH-OPEN-FILE (stream *LOAD-PATHNAME*) 49 | (LOAD stream (kw PRINT) PRINT))) 50 | (cl:values T)) 51 | (t 52 | (type-error file '(OR PATHNAME STRING STREAM)))))) 53 | 54 | (DEFVAR *compilation-unit* nil) 55 | (DEFVAR *deferred-compilation-actions* nil) 56 | 57 | (cl:defmacro WITH-COMPILATION-UNIT ((&key OVERRIDE) &body body) 58 | `(PROGN 59 | (LET ((*compilation-unit* T)) 60 | ,@body) 61 | (WHEN (OR ,OVERRIDE (NOT *compilation-unit*)) 62 | (DOLIST (fn (NREVERSE *deferred-compilation-actions*)) 63 | (FUNCALL fn)) 64 | (SETQ *deferred-compilation-actions* nil)))) 65 | 66 | (defmacro* WITH-COMPILATION-UNIT ((&key OVERRIDE) &body body) 67 | `(progn 68 | (let ((*compilation-unit* T)) 69 | ,@body) 70 | (when (or ,OVERRIDE (not *compilation-unit*)) 71 | (dolist (fn (nreverse *deferred-compilation-actions*)) 72 | (FUNCALL fn)) 73 | (setq *deferred-compilation-actions* nil)))) 74 | 75 | (DEFVAR *FEATURES* (list ;; TODO: (kw ANSI-CL) 76 | (kw EMACS-CL) 77 | (kw COMMON-LISP))) 78 | 79 | (let ((cons (ASSOC (emacs-version) 80 | `(("GNU Emacs" . ,(kw GNU-EMACS)) 81 | ("XEmacs" . ,(kw XEMACS)) 82 | ("Hemlock" . ,(kw HEMLOCK))) 83 | (kw TEST) (lambda (version string) 84 | (STRING= version string 85 | (kw END1) (LENGTH string)))))) 86 | (push (if cons (cdr cons) (kw UNKNOWN-EMACS)) *FEATURES*)) 87 | 88 | (DEFVAR *COMPILE-FILE-PATHNAME* nil) 89 | (DEFVAR *COMPILE-FILE-TRUENAME* nil) 90 | 91 | (DEFVAR *LOAD-PATHNAME* nil) 92 | (DEFVAR *LOAD-TRUENAME* nil) 93 | 94 | (DEFVAR *COMPILE-PRINT* nil) 95 | (DEFVAR *COMPILE-VERBOSE* nil) 96 | 97 | (DEFVAR *LOAD-PRINT* nil) 98 | (DEFVAR *LOAD-VERBOSE* nil) 99 | 100 | (DEFVAR *MODULES* nil) 101 | 102 | (defun PROVIDE (name) 103 | (let ((string (STRING name))) 104 | (pushnew string *MODULES* :test #'STRING=) 105 | string)) 106 | 107 | (defun REQUIRE (name &optional pathnames) 108 | (let ((string (STRING name))) 109 | (unless (find string *MODULES* :test #'STRING=) 110 | (do-list-designator (file pathnames) 111 | (LOAD file))))) 112 | -------------------------------------------------------------------------------- /src/cl-typep.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements the TYPEP function from chapter 4, Types and Classes. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | (defvar *atomic-typespecs* (make-hash-table)) 9 | (defvar *compound-typespecs* (make-hash-table)) 10 | 11 | (defun ensure-type (name predicate) 12 | (setf (gethash name *atomic-typespecs*) predicate)) 13 | 14 | ;;; Implements TYPEP for "typespec". 15 | (defmacro* define-typep ((var typespec env &optional compound-only) &body body) 16 | (if (consp typespec) 17 | `(progn 18 | (setf (gethash ',(first typespec) *compound-typespecs*) 19 | (function* (lambda (,var ,env ,@(rest typespec)) ,@body))) 20 | ,@(unless compound-only 21 | `((ensure-type ',(first typespec) 22 | (function* (lambda (,var ,env ,@(rest typespec)) 23 | ,@body)))))) 24 | `(ensure-type ',typespec (function* (lambda (,var ,env) ,@body))))) 25 | 26 | (defun in-range (num low high) 27 | "Check that NUM is in the range specified by the interval designators 28 | LOW and HIGH." 29 | (let* ((low-exclusive (consp low)) 30 | (low (if low-exclusive (car low) low)) 31 | (high-exclusive (consp high)) 32 | (high (if high-exclusive (car high) high))) 33 | (and (cond 34 | ((eq low star) t) 35 | (low-exclusive (cl:< low num)) 36 | (t (cl:<= low num))) 37 | (cond 38 | ((eq high star) t) 39 | (high-exclusive (cl:< num high)) 40 | (t (cl:<= num high)))))) 41 | 42 | (defvar star (INTERN "*" "EMACS-CL")) 43 | 44 | (defmacro star-or (type &rest forms) 45 | `(or (eq ,type star) ,@forms)) 46 | 47 | 48 | ;;; Definitions for all type specifiers recognized by TYPEP follows. 49 | 50 | (define-typep (object (AND &rest types) env :compound-only) 51 | (every (lambda (type) (TYPEP object type env)) types)) 52 | 53 | (define-typep (object (ARRAY &optional (type star) (dims star)) env) 54 | (and (ARRAYP object) 55 | (star-or type (eq (UPGRADED-ARRAY-ELEMENT-TYPE type) 56 | (ARRAY-ELEMENT-TYPE object))) 57 | (cond 58 | ((eq dims star) 'T) 59 | ((INTEGERP dims) (eql (ARRAY-RANK object) dims)) 60 | (t (dims-match dims (ARRAY-DIMENSIONS object)))))) 61 | 62 | (defun dims-match (d1 d2) 63 | (cond 64 | ((null d1) (null d2)) 65 | ((null d2) nil) 66 | (t (and (or (eq (first d1) star) 67 | (eq (first d2) star) 68 | (eql (first d1) (first d2))) 69 | (dims-match (rest d1) (rest d2)))))) 70 | 71 | (define-typep (object CHARACTER env) 72 | (CHARACTERP object)) 73 | 74 | (define-typep (object COMPILED-FUNCTION env) 75 | (COMPILED-FUNCTION-P object)) 76 | 77 | (define-typep (object (COMPLEX &optional (type star)) env) 78 | (and (COMPLEXP object) 79 | (star-or 80 | type 81 | (unless (cl:values (SUBTYPEP type 'REAL)) 82 | (ERROR "(COMPLEX ~S) is not a valid type specifier." type)) 83 | 'T))) 84 | 85 | (define-typep (object (CONS &optional (car-type star) (cdr-type star)) env) 86 | (and (consp object) 87 | (star-or car-type (TYPEP (car object) car-type env)) 88 | (star-or cdr-type (TYPEP (cdr object) cdr-type env)))) 89 | 90 | (define-typep (obj1 (EQL obj2) env :compound-only) 91 | (EQL obj1 obj2)) 92 | 93 | (define-typep (object FUNCTION env) 94 | (FUNCTIONP object)) 95 | 96 | (define-typep (object (FUNCTION &rest args) env :compound-only) 97 | (ERROR "TYPEP does not accept a compound FUNCTION type specifier.")) 98 | 99 | (define-typep (object HASH-TABLE env) 100 | (HASH-TABLE-P object)) 101 | 102 | (define-typep (object (INTEGER &optional (low star) (high star)) env) 103 | (and (INTEGERP object) (in-range object low high))) 104 | 105 | (define-typep (object INTERPRETED-FUNCTION env) 106 | (INTERPRETED-FUNCTION-P object)) 107 | 108 | (define-typep (object KEYWORD env) 109 | (KEYWORDP object)) 110 | 111 | (define-typep (object LOGICAL-PATHNAME env) 112 | (vector-and-typep object 'LOGICAL-PATHNAME)) 113 | 114 | (define-typep (object nil env) 115 | nil) 116 | 117 | (define-typep (object (NOT type) env :compound-only) 118 | (not (TYPEP object type env))) 119 | 120 | (define-typep (object (OR &rest types) env :compound-only) 121 | (some (lambda (type) (TYPEP object type env)) types)) 122 | 123 | (define-typep (object PACKAGE env) 124 | (PACKAGEP object)) 125 | 126 | (define-typep (object PATHNAME env) 127 | (PATHNAMEP object)) 128 | 129 | (define-typep (object RANDOM-STATE env) 130 | (RANDOM-STATE-P object)) 131 | 132 | (define-typep (object (RATIONAL &optional (low star) (high star)) env) 133 | (and (RATIONALP object) (in-range object low high))) 134 | 135 | (define-typep (object (SATISFIES fn) env :compound-only) 136 | (unless (symbolp fn) 137 | (type-error fn '(CONS (EQL SATISFIES) (CONS SYMBOL NULL)))) 138 | (funcall fn object)) 139 | 140 | (define-typep (object (SIMPLE-ARRAY &optional (type star) (dims star)) env) 141 | (and (or (bit-vector-p object) 142 | (stringp object) 143 | (SIMPLE-VECTOR-P object)) 144 | (star-or type 145 | (eq (UPGRADED-ARRAY-ELEMENT-TYPE type) 146 | (ARRAY-ELEMENT-TYPE object))) 147 | (star-or dims 148 | (eql dims 1) 149 | (equal dims (list star))))) 150 | 151 | (define-typep (object (SINGLE-FLOAT &optional (low star) (high star)) env) 152 | (and (floatp object) (in-range object low high))) 153 | 154 | (define-typep (object STANDARD-CHAR env) 155 | (and (CHARACTERP object) 156 | (STANDARD-CHAR-P object))) 157 | 158 | (define-typep (object SYMBOL env) 159 | (SYMBOLP object)) 160 | 161 | (define-typep (object T env) 162 | T) 163 | 164 | (define-typep (object (VALUES &rest args) env :compound-only) 165 | (ERROR "TYPEP does not accept a VALUES type specifier.")) 166 | 167 | 168 | 169 | (defun TYPEP (object type &optional env) 170 | (setq type (expand-type type env)) 171 | (cond 172 | ((consp type) 173 | (let ((fn (gethash (first type) *compound-typespecs*))) 174 | (if fn 175 | (APPLY fn object env (rest type)) 176 | (error "invalid typespec: %s" type)))) 177 | ((symbolp type) 178 | (let ((fn (gethash type *atomic-typespecs*))) 179 | (if fn 180 | (FUNCALL fn object env) 181 | (ERROR "Invalid typespec: ~A" type)))) 182 | (t 183 | (type-error type '(OR SYMBOL CONS CLASS))))) 184 | 185 | ;;; Bootstrap issue. Redefined later. 186 | (defun INTERPRETED-FUNCTION-P (fn) 187 | nil) 188 | -------------------------------------------------------------------------------- /src/cl-types.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file implements operators in chapter 4, Types and Classes. 5 | 6 | (IN-PACKAGE "EMACS-CL") 7 | 8 | ;;; TODO: GENERIC-FUNCTION 9 | ;;; TODO: STANDARD-GENERIC-FUNCTION 10 | ;;; TODO: CLASS 11 | ;;; TODO: BUILT-IN-CLASS 12 | ;;; TODO: STRUCTURE-CLASS 13 | ;;; TODO: STANDARD-CLASS 14 | ;;; TODO: METHOD 15 | ;;; TODO: STANDARD-METHOD 16 | ;;; TODO: STRUCTURE-OBJECT 17 | ;;; TODO: STANDARD-OBJECT 18 | ;;; TODO: METHOD-COMBINATION 19 | 20 | (unless (fboundp 'puthash) 21 | (defun puthash (key value table) 22 | (setf (gethash key table) value))) 23 | 24 | (defun COERCE (object type) 25 | (cond 26 | ((or (eq type 'T) (TYPEP object type)) 27 | object) 28 | ((null type) 29 | (ERROR 'SIMPLE-TYPE-ERROR 30 | (kw format) "~S can't be coerced to type ~S." 31 | (kw args) (list object type))) 32 | ((cl:values (SUBTYPEP type 'SEQUENCE)) 33 | (when (consp type) 34 | (let ((n (second type))) 35 | (when (and (eq (first type) 'ARRAY) 36 | (listp n)) 37 | (unless (eql (length n) 1) 38 | (ERROR 'TYPE-ERROR)) 39 | (setq n (first n))) 40 | (unless (or (eq n star) 41 | (eql n (LENGTH object))) 42 | (ERROR 'TYPE-ERROR)))) 43 | (MAP type #'IDENTITY object)) 44 | ((eq type 'CHARACTER) 45 | (CHARACTER object)) 46 | ((eq type 'COMPLEX) 47 | (cond 48 | ((RATIONALP object) object) 49 | ((FLOATP object) (COMPLEX object 0.0)) 50 | (t (type-error object 'NUMBER)))) 51 | ((cl:values (SUBTYPEP type 'FLOAT)) 52 | (FLOAT object)) 53 | ((eq type 'FUNCTION) 54 | (if (lambda-expr-p object) 55 | (cl:values (COMPILE nil object)) 56 | (FDEFINITION object))) 57 | (t 58 | (ERROR 'SIMPLE-TYPE-ERROR 59 | (kw format) "~S can't be coerced to type ~S." 60 | (kw args) (list object type))))) 61 | 62 | (defvar *deftype-expanders* (make-hash-table)) 63 | 64 | (defmacro* cl:deftype (name lambda-list &body body) 65 | `(progn 66 | (puthash ',name 67 | ,(make-macro-el-function name lambda-list body) 68 | *deftype-expanders*) 69 | ',name)) 70 | 71 | (cl:defmacro DEFTYPE (name lambda-list &body body &environment env) 72 | `(EVAL-WHEN (,(kw COMPILE-TOPLEVEL) ,(kw LOAD-TOPLEVEL) ,(kw EXECUTE)) 73 | (puthash (QUOTE ,name) 74 | ,(make-macro-function name lambda-list body env) 75 | *deftype-expanders*) 76 | (QUOTE ,name))) 77 | 78 | ;;; Redefined later. 79 | (defun classp (x) 80 | nil) 81 | 82 | (defun expand-type (orig-type env) 83 | (if (classp orig-type) 84 | (CLASS-NAME orig-type) 85 | (let* ((type (ensure-list orig-type)) 86 | (fn (gethash (first type) *deftype-expanders*))) 87 | (if fn 88 | (expand-type (FUNCALL fn type env) env) 89 | orig-type)))) 90 | 91 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 92 | 93 | 94 | (cl:deftype ATOM () 95 | '(NOT CONS)) 96 | 97 | (cl:deftype BASE-CHAR () 98 | 'CHARACTER) 99 | 100 | (cl:deftype BASE-STRING (&optional n) 101 | (unless n (setq n star)) 102 | `(STRING ,n)) 103 | 104 | (cl:deftype BIGNUM () 105 | '(AND INTEGER (NOT FIXNUM))) 106 | 107 | (cl:deftype BIT () 108 | '(INTEGER 0 1)) 109 | 110 | (cl:deftype BIT-VECTOR (&optional n) 111 | (unless n (setq n star)) 112 | `(ARRAY BIT (,n))) 113 | 114 | (cl:deftype BOOLEAN () 115 | '(MEMBER nil T)) 116 | 117 | (cl:deftype DOUBLE-FLOAT (&optional m n) 118 | (unless m (setq m star)) 119 | (unless n (setq n star)) 120 | `(SINGLE-FLOAT ,m ,n)) 121 | 122 | (cl:deftype EXTENDED-CHAR () 123 | '(AND CHARACTER (NOT BASE-CHAR))) 124 | 125 | (cl:deftype FIXNUM () 126 | (eval-when-compile `(INTEGER ,most-negative-fixnum ,most-positive-fixnum))) 127 | 128 | (cl:deftype FLOAT (&optional m n) 129 | (unless m (setq m star)) 130 | (unless n (setq n star)) 131 | `(SINGLE-FLOAT ,m ,n)) 132 | 133 | (cl:deftype LIST () 134 | '(OR NULL CONS)) 135 | 136 | (cl:deftype LONG-FLOAT (&optional m n) 137 | (unless m (setq m star)) 138 | (unless n (setq n star)) 139 | `(SINGLE-FLOAT ,m ,n)) 140 | 141 | (cl:deftype MEMBER (&rest objects) 142 | `(OR ,@(mapcar (curry #'list 'EQL) objects))) 143 | 144 | (cl:deftype MOD (n) 145 | `(INTEGER 0 ,(binary+ n -1))) 146 | 147 | (cl:deftype NULL () 148 | '(EQL nil)) 149 | 150 | (cl:deftype NUMBER () 151 | '(OR REAL COMPLEX)) 152 | 153 | (cl:deftype RATIO () 154 | '(AND RATIONAL (NOT INTEGER))) 155 | 156 | (cl:deftype REAL (&optional m n) 157 | (unless m (setq m star)) 158 | (unless n (setq n star)) 159 | `(OR (RATIONAL ,m ,n) (SINGLE-FLOAT ,m ,n))) 160 | 161 | (cl:deftype SEQUENCE () 162 | '(OR LIST VECTOR)) 163 | 164 | (cl:deftype SHORT-FLOAT (&optional m n) 165 | (unless m (setq m star)) 166 | (unless n (setq n star)) 167 | `(SINGLE-FLOAT ,m ,n)) 168 | 169 | (cl:deftype SIGNED-BYTE (&optional n) 170 | (unless n (setq n star)) 171 | (let ((m n)) 172 | (unless (eq n star) 173 | (setq n (EXPT 2 (cl:1- n))) 174 | (setq m (cl:- n)) 175 | (setq n (cl:1- n))) 176 | `(INTEGER ,m ,n))) 177 | 178 | (cl:deftype SIMPLE-BASE-STRING (&optional n) 179 | (unless n (setq n star)) 180 | `(SIMPLE-STRING (,n))) 181 | 182 | (cl:deftype SIMPLE-BIT-VECTOR (&optional n) 183 | (unless n (setq n star)) 184 | `(SIMPLE-ARRAY BIT (,n))) 185 | 186 | (cl:deftype SIMPLE-STRING (&optional n) 187 | (unless n (setq n star)) 188 | `(OR (SIMPLE-ARRAY CHARACTER (,n)) 189 | (SIMPLE-ARRAY nil (,n)))) 190 | 191 | (cl:deftype SIMPLE-VECTOR (&optional n) 192 | (unless n (setq n star)) 193 | `(SIMPLE-ARRAY T (,n))) 194 | 195 | (cl:deftype STRING (&optional n) 196 | (unless n (setq n star)) 197 | `(OR (ARRAY CHARACTER (,n)) 198 | (ARRAY nil (,n)))) 199 | 200 | (cl:deftype UNSIGNED-BYTE (&optional n) 201 | (unless n (setq n star)) 202 | (unless (eq n star) 203 | (setq n (cl:1- (EXPT 2 n)))) 204 | `(INTEGER 0 ,n)) 205 | 206 | (cl:deftype VECTOR (&whole w &optional type n) 207 | (when (null (rest w)) (setq type star)) 208 | (unless n (setq n star)) 209 | `(ARRAY ,type (,n))) 210 | 211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | 213 | 214 | (defun TYPE-OF (object) 215 | (case object 216 | ((nil) 'NULL) 217 | (T 'BOOLEAN) 218 | ((0 1) 'BIT) 219 | (t 220 | (ecase (type-of object) 221 | ;; This is supposed to be an exhaustive enumeration of all 222 | ;; possible return values for Emacs Lisp type-of. 223 | ((bit-vector bool-vector) 224 | `(SIMPLE-BIT-VECTOR ,(length object))) 225 | (subr 226 | 'COMPILED-FUNCTION) 227 | (compiled-function 228 | (let ((info (gethash object *funcallable-objects*))) 229 | (if info 230 | (car info) 231 | 'COMPILED-FUNCTION))) 232 | (character 'CHARACTER) 233 | (cons 'CONS) 234 | (float 'SINGLE-FLOAT) 235 | (hash-table 'HASH-TABLE) 236 | (integer (if (minusp object) 237 | 'FIXNUM 238 | `(INTEGER 0 ,MOST-POSITIVE-FIXNUM))) 239 | (string `(SIMPLE-STRING ,(length object))) 240 | (symbol (if (eq (SYMBOL-PACKAGE object) *keyword-package*) 241 | 'KEYWORD 242 | 'SYMBOL)) 243 | (vector 244 | (case (aref object 0) 245 | (ARRAY `(ARRAY T ,(array-dims object))) 246 | (BIGNUM (if (MINUSP object) 247 | 'BIGNUM 248 | `(INTEGER ,(binary+ MOST-POSITIVE-FIXNUM 1)))) 249 | (bit-array `(ARRAY BIT ,(array-dims object))) 250 | (BIT-VECTOR `(BIT-VECTOR ,(vector-size object))) 251 | (char-array `(ARRAY CHARACTER ,(array-dims object))) 252 | (CHARACTER 'CHARACTER) 253 | (COMPLEX 'COMPLEX) 254 | (INTERPRETED-FUNCTION 255 | 'INTERPRETED-FUNCTION) 256 | (RATIO 'RATIO) 257 | (SIMPLE-VECTOR 258 | `(SIMPLE-VECTOR ,(1- (length object)))) 259 | (STRING `(STRING ,(vector-size object))) 260 | (VECTOR `(VECTOR T ,(vector-size object))) 261 | (t (aref object 0)))) 262 | ;; For now, throw an error on these. 263 | ((buffer char-table frame marker overlay process 264 | subr window window-configuration) 265 | (error "Unknown type: %s" (type-of object))))))) 266 | 267 | ;;; TYPEP defined in cl-typep.el. 268 | 269 | ;;; TYPE-ERROR, TYPE-ERROR-DATUM, TYPE-ERROR-EXPECTED-TYPE, and 270 | ;;; SIMPLE-TYPE-ERROR defined in cl-conditions.el. 271 | -------------------------------------------------------------------------------- /src/emacs-cl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | EMACS=emacs 3 | DIR=/home/lars/src/emacs-cl 4 | exec $EMACS -batch -l $DIR/load-cl.el -l $DIR/batch.el -f batch-repl 5 | -------------------------------------------------------------------------------- /src/func.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file provides cl:lambda, cl:function, and cl:defun. 5 | 6 | (defmacro cl:function (name) 7 | (let ((fn (FDEFINITION name))) 8 | (if (subrp fn) 9 | ;; Have to return symbol since # in .elc isn't readable. 10 | `',name 11 | fn))) 12 | 13 | (defmacro cl:defun (name lambda-list &rest body) 14 | (when byte-compile-warnings 15 | (byte-compile-log-1 (format "cl:defun %s" name))) 16 | `(progn 17 | (fset ',name (cl:lambda ,lambda-list ,@body)) 18 | ',name)) 19 | 20 | (defmacro parse-parameter (p kind k v i s err) 21 | `(cond 22 | ((or (symbolp ,p) (not (memq ,kind '(&OPTIONAL &KEY &AUX)))) 23 | (when (and ',k (eq ,kind '&KEY) (not (listp ,p))) 24 | (setq ,k (keyword (symbol-name ,p)))) 25 | (when ',v (setq ,v ,p))) 26 | ((and (consp ,p) (<= (length ,p) 3)) 27 | (cond 28 | ((or (symbolp (first ,p)) (not (eq ,kind '&KEY))) 29 | (when (and ',k (eq ,kind '&KEY)) 30 | (setq ,k (keyword (symbol-name (first ,p))))) 31 | (when ',v (setq ,v (first ,p)))) 32 | ((and (consp (first ,p)) (= (length (first ,p)) 2)) 33 | (when ',k (setq ,k (first (first ,p)))) 34 | (when ',v (setq ,v (second (first ,p))))) 35 | (t 36 | ,err)) 37 | (when ',i (setq ,i (second ,p))) 38 | (when ',s (setq ,s (third ,p)))) 39 | (t 40 | ,err))) 41 | 42 | (defmacro* do-lambda-list ((var kind lambda-list &optional result 43 | &key (keywords 'LAMBDA-LIST-KEYWORDS)) 44 | &body body) 45 | (let ((keyword-var nil) 46 | (var-var nil) 47 | (default-var nil) 48 | (supplied-var nil) 49 | (v (gensym))) 50 | (parse-parameter var '&KEY keyword-var var-var default-var supplied-var 51 | (error "Syntax error in do-lambda-list.")) 52 | (with-gensyms (list) 53 | `(do ((,kind :required) 54 | (,list ,lambda-list (rest ,list))) 55 | ((atom ,list) 56 | (unless (null ,list) 57 | (setq ,kind '&REST) 58 | (let (,@(when keyword-var `((,keyword-var nil))) 59 | ,@(when var-var `((,var-var ,list))) 60 | ,@(when default-var `((,default-var nil))) 61 | ,@(when supplied-var `((,supplied-var nil)))) 62 | ,@body)) 63 | ,result) 64 | (let ((,v (car ,list))) 65 | (if (memq ,v ,keywords) 66 | (setq ,kind ,v) 67 | (let ,(remove nil (list var-var keyword-var 68 | default-var supplied-var)) 69 | (parse-parameter ,v ,kind ,keyword-var ,var-var ,default-var 70 | ,supplied-var (ERROR 'PROGRAM-ERROR)) 71 | ,@body 72 | (when (memq ,kind '(&ENVIRONMENT &WHOLE)) 73 | (setq ,kind :required))))))))) 74 | 75 | ;;; Allowed lambda list keywords: 76 | ;;; Ordinary &optional &rest &key &allow-other-keys &aux 77 | ;;; Generic Function &optional &rest &key &allow-other-keys 78 | ;;; Specialized &optional &rest &key &allow-other-keys &aux 79 | ;;; Macro &whole &optional &rest &body &key &allow-other-keys 80 | ;;; &aux &environment 81 | ;;; Destructuring &whole &optional &rest &body &key &allow-other-keys 82 | ;;; &aux 83 | ;;; Boa Same as Ordinary. 84 | ;;; Defsetf &optional &rest &key &allow-other-keys &environment 85 | ;;; Deftype Same as Macro. 86 | ;;; Define-modify-macro &optional &rest 87 | ;;; Define-method-combination 88 | ;;; &whole &optional &rest &key &allow-other-keys &aux 89 | 90 | (defvar rest-sym (make-symbol "rest")) 91 | 92 | (defvar unbound (make-symbol "unbound")) 93 | 94 | (defun* simplify-lambda-list (lambda-list &optional env) 95 | (let ((result nil) 96 | (push-optional t)) 97 | (do-lambda-list ((var default supp) kind lambda-list) 98 | (case kind 99 | (&OPTIONAL 100 | (when push-optional 101 | (push '&optional result) 102 | (setq push-optional nil))) 103 | ((&REST &KEY) 104 | (push '&rest result) 105 | (push rest-sym result) 106 | (return-from simplify-lambda-list (nreverse result))) 107 | (&AUX 108 | (return-from simplify-lambda-list (nreverse result)))) 109 | (when (or default supp) 110 | (when (eq (car result) '&optional) 111 | (pop result)) 112 | (push '&rest result) 113 | (push rest-sym result) 114 | (return-from simplify-lambda-list (nreverse result))) 115 | (push (if env (compile-variable var env) var) 116 | result)) 117 | (nreverse result))) 118 | 119 | (defun* lambda-list-bindings (lambda-list env) 120 | (let ((bindings nil) 121 | (optional-rest nil)) 122 | (do-lambda-list ((var default supp) kind lambda-list) 123 | (when env 124 | (setq var (compile-variable var env)) 125 | (when supp 126 | (setq supp (compile-variable supp env)))) 127 | (case kind 128 | (&OPTIONAL 129 | (when (or default supp) 130 | (setq optional-rest t)) 131 | (when optional-rest 132 | (when supp 133 | (push `(,supp ,rest-sym) bindings)) 134 | (when env 135 | (setq default (compile-form default env))) 136 | (push `(,var (if ,rest-sym (pop ,rest-sym) ,default)) 137 | bindings))) 138 | (&REST 139 | (push `(,var ,rest-sym) bindings)) 140 | (&KEY 141 | (push `(,var ',unbound) bindings) 142 | (when supp 143 | (push `(,supp nil) bindings))) 144 | (&AUX 145 | (push var bindings)))) 146 | (nreverse bindings))) 147 | 148 | (defun lambda-list-keys (lambda-list) 149 | (with-collector collect 150 | (do-lambda-list (((key var)) kind lambda-list) 151 | (when (eq kind '&KEY) 152 | (collect key))))) 153 | 154 | (defun lambda-list-keyword-vars (lambda-list env &optional include-supplied) 155 | (with-collector collect 156 | (do-lambda-list ((var nil supp) kind lambda-list) 157 | (when (eq kind '&KEY) 158 | (collect (if env (lexical-value var env) var)) 159 | (when (and supp include-supplied) 160 | (collect (if env (lexical-value supp env) supp))))))) 161 | 162 | (defun lambda-list-keyword-defaults (lambda-list) 163 | (with-collector collect 164 | (do-lambda-list ((var default) kind lambda-list) 165 | (when (eq kind '&KEY) 166 | (collect default))))) 167 | 168 | (defun load-time-symbol (sym) 169 | (if (or (not (boundp '*keyword-package*)) 170 | (eq (SYMBOL-PACKAGE sym) *keyword-package*)) 171 | `(keyword ,(symbol-name sym)) 172 | `(INTERN ,(symbol-name sym) ,(PACKAGE-NAME (SYMBOL-PACKAGE sym))))) 173 | 174 | (defun keyword-assignments (lambda-list env) 175 | (let ((allow-other-keys-p (memq '&ALLOW-OTHER-KEYS lambda-list)) 176 | (temp (gensym)) 177 | (allow (gensym)) 178 | (val (gensym)) 179 | (keys (lambda-list-keys lambda-list)) 180 | (vars (lambda-list-keyword-vars lambda-list env)) 181 | (defaults (lambda-list-keyword-defaults lambda-list))) 182 | (when keys 183 | (let* ((list `(list ,@(mapcar #'load-time-symbol keys))) 184 | (keyword-list 185 | (if (eval-when-compile (featurep 'xemacs)) 186 | list 187 | `(load-time-value ,list))) 188 | (body 189 | `((while ,rest-sym 190 | (let ((,temp (position (pop ,rest-sym) ,keyword-list)) ,val) 191 | ,@(unless allow-other-keys-p 192 | `((unless (or ,temp ,allow) (ERROR 'PROGRAM-ERROR)))) 193 | (when (null ,rest-sym) 194 | (ERROR 'PROGRAM-ERROR)) 195 | (setq ,val (pop ,rest-sym)) 196 | (when ,temp 197 | (set (nth ,temp ',vars) ,val)))) 198 | ,@(mappend (lambda (var default) 199 | `((when (eq ,var ',unbound) 200 | (setq ,var 201 | ,(if env 202 | (compile-form default env) 203 | default))))) 204 | vars defaults)))) 205 | (unless allow-other-keys-p 206 | (setq body 207 | `((let ((,allow (cadr (memq (kw ALLOW-OTHER-KEYS) ,rest-sym)))) 208 | ,@body)))) 209 | body)))) 210 | 211 | (defun aux-assignments (lambda-list env) 212 | (let ((bindings nil)) 213 | (do-lambda-list ((var default) kind lambda-list) 214 | (when (and (eq kind '&AUX) 215 | default) 216 | (when env 217 | (setq var (compile-variable var env) 218 | default (compile-form default env))) 219 | (push `(,var ,default) bindings))) 220 | (when bindings 221 | `((setq ,@(nreverse bindings)))))) 222 | 223 | (defun translate-lambda-list (lambda-list env) 224 | (mapcar (lambda (x) 225 | (let ((cons (assq x '((&OPTIONAL . &optional) (&REST . &rest))))) 226 | (cond 227 | (cons (cdr cons)) 228 | (env (compile-variable x env)) 229 | (t x)))) 230 | lambda-list)) 231 | 232 | (defun lambda-list-variables (lambda-list) 233 | (let ((result nil)) 234 | (do-lambda-list ((var default supp) kind lambda-list) 235 | (if (symbolp var) 236 | (push var result) 237 | (setq result (nconc result (lambda-list-variables var)))) 238 | (when supp (push supp result))) 239 | result)) 240 | 241 | (defun expand-lambda (lambda-list body &optional env) 242 | (if (and (every 'symbolp lambda-list) 243 | (notany (lambda (x) (memq x '(&KEY &AUX))) lambda-list)) 244 | ;; Easy case: no defaults, suppliedp, keyword, or aux parameters. 245 | `(lambda ,(translate-lambda-list lambda-list env) ,@body) 246 | ;; Difficult case: 247 | `(lambda ,(simplify-lambda-list lambda-list env) 248 | (let* ,(lambda-list-bindings lambda-list env) 249 | ;; ,@(unless (or (memq '&REST lambda-list) (memq '&KEY lambda-list)) 250 | ;; `((when ,rest-sym 251 | ;; (ERROR 'PROGRAM-ERROR)))) 252 | ,@(keyword-assignments lambda-list env) 253 | ,@(aux-assignments lambda-list env) 254 | ,@body)))) 255 | 256 | (defmacro cl:lambda (lambda-list &rest body) 257 | ; (byte-compile 258 | (expand-lambda lambda-list body));) 259 | -------------------------------------------------------------------------------- /src/interaction.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; A major mode implementing an Emacs Common Lisp listener. 5 | 6 | (defvar emacs-cl-prompt-marker nil 7 | "Position of last prompt.") 8 | 9 | (defvar emacs-cl-history '("") 10 | "Common Lisp listener command history.") 11 | 12 | (defvar emacs-cl-history-index 0 13 | "Common Lisp listener command history index.") 14 | 15 | (defun emacs-cl () 16 | "Starts a Common Lisp listener." 17 | (interactive) 18 | (switch-to-buffer (generate-new-buffer "*Emacs Common Lisp*")) 19 | (emacs-cl-mode) 20 | (setq *STANDARD-OUTPUT* (make-buffer-output-stream (current-buffer)) 21 | *ERROR-OUTPUT* *STANDARD-OUTPUT* 22 | *TRACE-OUTPUT* *STANDARD-OUTPUT*) 23 | (setq *STANDARD-INPUT* 24 | (MAKE-ECHO-STREAM (make-read-char-exclusive-input-stream) 25 | *STANDARD-OUTPUT*)) 26 | (setq *TERMINAL-IO* (MAKE-TWO-WAY-STREAM *STANDARD-INPUT* *STANDARD-OUTPUT*) 27 | *QUERY-IO* *TERMINAL-IO*) 28 | (setq standard-output 29 | (if use-character-type-p 30 | (lambda (char) (WRITE-CHAR char *STANDARD-OUTPUT*)) 31 | (lambda (char) (WRITE-CHAR (CODE-CHAR char) *STANDARD-OUTPUT*)))) 32 | (insert (PACKAGE-NAME *PACKAGE*) "> ") 33 | (setq emacs-cl-prompt-marker (point-marker))) 34 | 35 | (defun emacs-cl-mode () 36 | "Major mode for an Emacs Common Lisp listener. 37 | 38 | \\[emacs-cl-newline] Process current line 39 | \\[emacs-cl-beginning-of-line] Go to start of current line 40 | \\[emacs-cl-history-previous] Previous line in history 41 | \\[emacs-cl-history-next] Next line in history 42 | \\[emacs-cl-beginning-of-line] Go to start of current line" 43 | (interactive) 44 | (kill-all-local-variables) 45 | (setq major-mode 'emacs-cl-mode) 46 | (setq mode-name "Emacs Common Lisp") 47 | (use-local-map emacs-cl-mode-map) 48 | (make-variable-buffer-local 'emacs-cl-prompt-marker) 49 | (make-variable-buffer-local 'emacs-cl-history) 50 | (make-variable-buffer-local 'emacs-cl-history-index) 51 | (run-hooks 'emacs-cl-mode-hooks)) 52 | 53 | (defvar emacs-cl-mode-map nil 54 | "Local keymap for Emacs Common Lisp listener buffers.") 55 | 56 | (unless emacs-cl-mode-map 57 | (setq emacs-cl-mode-map (make-keymap)) 58 | (define-key emacs-cl-mode-map "\C-m" 'emacs-cl-newline) 59 | (define-key emacs-cl-mode-map "\C-a" 'emacs-cl-beginning-of-line) 60 | (define-key emacs-cl-mode-map "\M-p" 'emacs-cl-history-previous) 61 | (define-key emacs-cl-mode-map "\M-n" 'emacs-cl-history-next)) 62 | 63 | (defun* emacs-cl-eval-interactively (form) 64 | (save-current-buffer 65 | (set (INTERN "-" "CL") form) 66 | (let ((*-sym (INTERN "*" "CL")) 67 | (/-sym (INTERN "/" "CL")) 68 | (+-sym (INTERN "+" "CL")) 69 | (values 70 | (restart-bind ((ABORT (lambda () 71 | (return-from emacs-cl-eval-interactively)))) 72 | (MULTIPLE-VALUE-LIST (EVAL form))))) 73 | (setq +++ ++ ++ (SYMBOL-VALUE +-sym)) 74 | (set +-sym form) 75 | (setq /// // // (SYMBOL-VALUE /-sym)) 76 | (set /-sym values) 77 | (setq *** ** ** (SYMBOL-VALUE *-sym)) 78 | (set *-sym (first values)) 79 | values))) 80 | 81 | (defun emacs-cl-get-line () 82 | (let ((line (buffer-substring emacs-cl-prompt-marker (point)))) 83 | (setf (nth 0 emacs-cl-history) line) 84 | (HANDLER-BIND 85 | ((END-OF-FILE 86 | (lambda (c) 87 | (insert "\n") 88 | (dotimes (i (+ (length (PACKAGE-NAME *PACKAGE*)) 2)) 89 | (insert " ")) 90 | (throw 'read-continue nil))) 91 | (ERROR 92 | (lambda (c) 93 | (FORMAT T "~%Error: ~S" c) 94 | (throw 'read-error nil)))) 95 | (READ-FROM-STRING line)))) 96 | 97 | (defun emacs-cl-newline () 98 | (interactive) 99 | (catch 'read-continue 100 | (if (< (point) emacs-cl-prompt-marker) 101 | (insert "\n") 102 | (goto-char (point-max)) 103 | (when (> (point) emacs-cl-prompt-marker) 104 | (dolist (x (catch 'read-error 105 | (emacs-cl-eval-interactively (emacs-cl-get-line)))) 106 | (let* ((start (1+ (point))) 107 | (ignore (PPRINT x)) 108 | (end (point))) 109 | (put-text-property start end 'mouse-face 'modeline) 110 | ;(put-text-property start end 'keymap ...) 111 | (put-text-property start end 'emacs-cl-object x)))) 112 | (insert "\n" (PACKAGE-NAME *PACKAGE*) "> ") 113 | (setq emacs-cl-prompt-marker (point-marker)) 114 | (push "" emacs-cl-history) 115 | (setq emacs-cl-history-index 0)))) 116 | 117 | (defun emacs-cl-history-previous () 118 | (interactive) 119 | (when (and (>= (point) emacs-cl-prompt-marker) 120 | (< emacs-cl-history-index (1- (length emacs-cl-history)))) 121 | (when (zerop emacs-cl-history-index) 122 | (setf (nth 0 emacs-cl-history) 123 | (buffer-substring emacs-cl-prompt-marker (point)))) 124 | (goto-char (point-max)) 125 | (delete-region emacs-cl-prompt-marker (point)) 126 | (incf emacs-cl-history-index) 127 | (insert (nth emacs-cl-history-index emacs-cl-history)))) 128 | 129 | (defun emacs-cl-history-next () 130 | (interactive) 131 | (when (and (>= (point) emacs-cl-prompt-marker) 132 | (plusp emacs-cl-history-index)) 133 | (goto-char (point-max)) 134 | (delete-region emacs-cl-prompt-marker (point)) 135 | (decf emacs-cl-history-index) 136 | (insert (nth emacs-cl-history-index emacs-cl-history)))) 137 | 138 | (defun emacs-cl-beginning-of-line () 139 | (interactive) 140 | (if (< (point) emacs-cl-prompt-marker) 141 | (beginning-of-line) 142 | (progn 143 | (beginning-of-line) 144 | (when (< (point) emacs-cl-prompt-marker) 145 | (goto-char emacs-cl-prompt-marker))))) 146 | -------------------------------------------------------------------------------- /src/load-cl.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; Functions for loading and compiling the whole system. 5 | ;;; Loading this file also loads the system as a side effect. 6 | 7 | (require 'cl) 8 | (require 'byte-compile "bytecomp") 9 | 10 | (setq max-lisp-eval-depth 10000) 11 | (setq max-specpdl-size 10000) 12 | 13 | ;;; Fake IN-PACKAGE and FIND-PACKAGE until they are defined properly 14 | ;;; in cl-packages.el. 15 | (defmacro IN-PACKAGE (name) nil) 16 | (defun FIND-PACKAGE (name) nil) 17 | 18 | (unless (fboundp 'cl-mapcar-many) 19 | (fset 'cl-mapcar-many (symbol-function 'cl--mapcar-many))) 20 | 21 | (defvar *cl-files* 22 | '("utils" 23 | "func" 24 | 25 | "cl-evaluation" 26 | "cl-flow" 27 | "cl-numbers" 28 | "cl-conses" 29 | "cl-characters" 30 | "cl-strings" 31 | "cl-arrays" 32 | "cl-sequences" 33 | "cl-structures" 34 | "cl-iteration" 35 | 36 | "cl-symbols" 37 | "cl-packages" 38 | 39 | "cl-types" 40 | "cl-typep" 41 | "cl-subtypep" 42 | 43 | "cl-hash" 44 | "cl-streams" 45 | "cl-reader" 46 | "cl-printer" 47 | "cl-environment" 48 | "cl-filenames" 49 | "cl-files" 50 | "interaction" 51 | "cl-eval" 52 | "cl-system" 53 | 54 | "cl-loop" 55 | "cl-format" 56 | "cl-compile" 57 | "cl-objects" 58 | "cl-conditions" 59 | 60 | "populate")) 61 | 62 | (defun load-cl () 63 | (interactive) 64 | (let ((load-path (cons (file-name-directory load-file-name) load-path)) 65 | (debug-on-error t) 66 | (byte-compile-warnings nil)) 67 | (mapc #'load *cl-files*) 68 | (populate-packages) 69 | (garbage-collect))) 70 | 71 | (defun compile-cl () 72 | (interactive) 73 | (let ((byte-compile-warnings '(not cl-functions))) 74 | (dolist (file *cl-files*) 75 | (byte-compile-file (concat file ".el"))))) 76 | 77 | (when (string-match "^19" emacs-version) 78 | (dolist (x '(:required :optional-rest :weakness :type :read-only 79 | :constituent :whitespace :single-escape 80 | :multiple-escape :terminating-macro 81 | :non-terminating-macro :eof :special-operator 82 | :lexical :special :macro :symbol-macro)) 83 | (set x x))) 84 | 85 | (setq *global-environment* 86 | (vector 'environment 87 | ;; Variable information 88 | nil nil nil 89 | ;; Function information 90 | nil nil nil 91 | ;; Block and tagbody information 92 | nil nil)) 93 | 94 | (load-cl) 95 | (IN-PACKAGE "CL-USER") 96 | -------------------------------------------------------------------------------- /src/tests.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003 Lars Brinkhoff. 4 | 5 | (defun test-cl () 6 | (LOAD "tests.lisp")) 7 | -------------------------------------------------------------------------------- /src/utils.el: -------------------------------------------------------------------------------- 1 | ;;;; -*- emacs-lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2003, 2004 Lars Brinkhoff. 4 | ;;; This file provides various small utilities. 5 | 6 | (defun map-to-gensyms (list) 7 | (mapcar (lambda (x) (gensym)) list)) 8 | 9 | (defmacro* with-gensyms (syms &body body) 10 | ;;`(let ,(mapcar #'list syms '#1=((gensym) . #1#)) 11 | `(let ,(mapcar (lambda (sym) `(,sym ',(gensym))) syms) 12 | ,@body)) 13 | 14 | (defun cl:string (x) 15 | (cond 16 | ((stringp x) x) 17 | ((symbolp x) (symbol-name x)) 18 | (t (error "type error")))) 19 | 20 | (defun strcat (&rest string-designators) 21 | (apply #'concat (mapcar #'cl:string string-designators))) 22 | 23 | (defun symcat (&rest string-designators) 24 | (let ((sym (intern (apply #'strcat string-designators)))) 25 | (when (fboundp 'SYMBOL-PACKAGE) 26 | (setf (SYMBOL-PACKAGE sym) *PACKAGE*)) 27 | sym)) 28 | 29 | (defun cl:symcat (&rest string-designators) 30 | (let ((sym (INTERN (apply #'strcat string-designators)))) 31 | ;(when (fboundp 'SYMBOL-PACKAGE) 32 | (setf (SYMBOL-PACKAGE sym) *PACKAGE*);) 33 | sym)) 34 | 35 | (defun just-one (list) 36 | (cond 37 | ((atom list) list) 38 | ((cdr list) (error "error")) 39 | (t (car list)))) 40 | 41 | (defun mappend (fn &rest lists) 42 | (apply #'append 43 | (if (null (cdr lists)) 44 | (mapcar fn (car lists)) 45 | (cl-mapcar-many fn lists)))) 46 | 47 | (defun vector-and-typep (object type) 48 | (and (vectorp object) 49 | (eq (aref object 0) type))) 50 | 51 | (defun curry (fn &rest args1) 52 | `(lambda (&rest args2) 53 | (apply ',fn ,@(mapcar (lambda (x) (list 'quote x)) args1) args2))) 54 | 55 | (defun rcurry (fn &rest args2) 56 | `(lambda (&rest args1) (apply ',fn (append args1 ',args2)))) 57 | 58 | (defmacro compose (&rest fns) 59 | (if fns 60 | (let ((fn1 (car (last fns))) 61 | (fns (butlast fns))) 62 | `(lambda (&rest args) 63 | ,(reduce (lambda (f1 f2) `(,f1 ,f2)) fns 64 | :from-end t :initial-value `(apply ',fn1 args)))) 65 | #'identity)) 66 | 67 | (defun ensure-list (object) 68 | (if (listp object) 69 | object 70 | (list object))) 71 | 72 | (defmacro* do-list-designator ((var list &optional result) &body body) 73 | `(dolist (,var (ensure-list ,list) ,result) 74 | ,@body)) 75 | 76 | (defmacro* do-plist ((prop val plist &optional result) &body body) 77 | (with-gensyms (list) 78 | `(do ((,list ,plist) 79 | ,prop ,val) 80 | ((null ,list) 81 | ,result) 82 | (setq ,prop (pop ,list) ,val (pop ,list)) 83 | ,@body))) 84 | 85 | (defun el-keyword (symbol) 86 | (intern (concat ":" (symbol-name symbol)))) 87 | 88 | ;;; Bootstrap magic: this list of symbols will later be imported into 89 | ;;; the KEYWORD package. 90 | (defvar *initial-keywords* nil) 91 | 92 | ;;; Initially, this function pushes all created symbols onto 93 | ;;; *initial-keywords*. Later, it will be redefined to intern symbols 94 | ;;; into the KEYWORD package directly. 95 | (defun keyword (name) 96 | (let ((sym (find name *initial-keywords* :key 'symbol-name :test 'string=))) 97 | (or sym 98 | (let ((sym (make-symbol name))) 99 | (push sym *initial-keywords*) 100 | (set sym sym) 101 | sym)))) 102 | 103 | (if (eval-when-compile (featurep 'xemacs)) 104 | (defmacro kw (name) `(keyword ,(symbol-name name))) 105 | (defmacro kw (name) `(load-time-value (keyword ,(symbol-name name))))) 106 | 107 | (defun type-error (datum type) 108 | (ERROR 'TYPE-ERROR (kw DATUM) datum (kw EXPECTED-TYPE) type)) 109 | 110 | (defconst use-character-type-p (eq (type-of ?A) 'character)) 111 | 112 | (if use-character-type-p 113 | (progn 114 | (defmacro ch (code) (int-char code)) 115 | (defmacro ch= (char code) `(char= ,char ,(int-char code))) 116 | (defmacro cl-char (char) char) 117 | (defmacro el-char (char) char)) 118 | (progn 119 | (defmacro ch (code) (vector 'CHARACTER code)) 120 | (defmacro ch= (char code) `(eq (aref ,char 1) ,code)) 121 | (defmacro cl-char (char) `(vector 'CHARACTER ,char)) 122 | (defmacro el-char (char) `(aref ,char 1)))) 123 | 124 | (defmacro define-storage-layout (type slots) 125 | (let ((index 0)) 126 | `(progn 127 | ,@(mapcar (lambda (slot) 128 | `(defmacro ,(symcat type "-" slot) (object) 129 | (list 'aref object ,(incf index)))) 130 | slots) 131 | ',type))) 132 | 133 | ;;; This macro can be used instead of VALUES. 134 | (defmacro cl:values (&rest vals) 135 | (let ((n (length vals))) 136 | (case n 137 | (0 `(setq nvals 0 mvals nil)) 138 | (1 `(prog1 ,(car vals) (setq nvals 1 mvals nil))) 139 | (t `(prog1 140 | ,(car vals) 141 | (setq nvals ,n mvals (list ,@(cdr vals)))))))) 142 | 143 | (defun expand-tagbody-forms (body start end) 144 | (do ((clauses nil) 145 | (clause (list (list start))) 146 | (forms body (cdr forms))) 147 | ((null forms) 148 | (setq clause (append clause (list (list 'go end)))) 149 | (setq clauses (append clauses `(,clause))) 150 | clauses) 151 | (let ((form (first forms))) 152 | (cond 153 | ((atom form) 154 | (setq clause (append clause `((go ,form)))) 155 | (setq clauses (append clauses `(,clause))) 156 | (setq clause `((,form)))) 157 | (t 158 | (setq clause (append clause `(,form)))))))) 159 | 160 | (defmacro* tagbody (&body body) 161 | (let ((pc (gensym)) 162 | (start (gensym)) 163 | (end (gensym)) 164 | (throw-tag (gensym))) 165 | `(let ((,pc ',start)) 166 | (macrolet ((go (tag) 167 | (list 'throw 168 | (list 'quote ',throw-tag) 169 | (list 'quote tag)))) 170 | (while (not (eq ,pc ',end)) 171 | (setq ,pc 172 | (catch ',throw-tag 173 | (case ,pc 174 | ,@(expand-tagbody-forms body start end)))))) 175 | nil))) 176 | 177 | ;(defun tagbody-blocks (body start) 178 | ; (do ((n 0) 179 | ; (blocks nil) 180 | ; (block (list start)) 181 | ; (forms body (cdr forms))) 182 | ; ((null forms) 183 | ; (setq block (append block (list -1))) 184 | ; (setq blocks (append blocks `(,block))) 185 | ; blocks) 186 | ; (let ((form (first forms))) 187 | ; (cond 188 | ; ((atom form) 189 | ; (incf n) 190 | ; (setq block (append block `(,n))) 191 | ; (setq blocks (append blocks `(,block))) 192 | ; (setq block (list form))) 193 | ; (t 194 | ; (setq block (append block `(,form)))))))) 195 | 196 | ;(defun tagbody-functions (blocks) 197 | ; (let ((tags (do ((blocks blocks (cdr blocks)) 198 | ; (tags nil) 199 | ; (n 0)) 200 | ; ((null blocks) tags) 201 | ; (push (cons (pop (car blocks)) n) tags) 202 | ; (incf n))) 203 | ; (catch (gensym))) 204 | ; (mapcar (lambda (block) 205 | ; `(lambda () 206 | ; (macrolet ((go (tag) 207 | ; (list 'throw 208 | ; (list 'quote ',catch) 209 | ; (list 'quote (cdr (assq tag ',tags)))))) 210 | ; (catch ',catch 211 | ; ,@block)))) 212 | ; blocks))) 213 | 214 | ;(defmacro* tagbody (&body body) 215 | ; (let* ((pc (gensym)) 216 | ; (start (if (atom (first body)) (pop body) (gensym))) 217 | ; (blocks (tagbody-blocks body start))) 218 | ; `(let ((,pc 0)) 219 | ; (while (not (minusp ,pc)) 220 | ; (setq ,pc (funcall (aref (eval-when-compile 221 | ; (vector ,@(tagbody-functions blocks))) 222 | ; ,pc))))))) 223 | 224 | (defun mapcar2 (fn list) 225 | (when list 226 | (cons (funcall fn (first list) (second list)) 227 | (mapcar2 fn (cddr list))))) 228 | 229 | (defun tree-count (object tree) ; &KEY TEST KEY 230 | (cond 231 | ((eq object tree) 1) 232 | ((atom tree) 0) 233 | (t (+ (tree-count object (car tree)) 234 | (tree-count object (cdr tree)))))) 235 | 236 | (defmacro destructuring-lambda (lambda-list &rest body) 237 | (with-gensyms (args) 238 | `(lambda (&rest ,args) 239 | (destructuring-bind ,lambda-list ,args ,@body)))) 240 | 241 | (defmacro* define-case (name &key test) 242 | (setq test (if (and (consp test) (eq (car test) 'function)) 243 | (cdr test) 244 | (cons 'funcall (cdr test)))) 245 | `(progn 246 | (defmacro ,name (object &rest clauses) 247 | (with-gensyms (value) 248 | (let ((fn ',test)) 249 | `(let ((,value ,object)) 250 | (cond 251 | ,@(mapcar (destructuring-lambda ((x &rest forms)) 252 | `((cl:values (,@fn ,value ',x)) 253 | (progn ,@forms))) 254 | clauses)))))) 255 | ;; (defmacro ,(intern (concat "e" (symbol-name name))) (object &rest clauses) 256 | ;; (with-gensyms (value) 257 | ;; (let ((,value ,object)) 258 | ;; `(,name ,value 259 | ;; ,@clauses 260 | ;; (t (ERROR "No match for ~S in ~S." ,value ',name)))))) 261 | ',name)) 262 | 263 | (define-case subtypecase :test #'SUBTYPEP) 264 | 265 | ;; (defmacro with-collector (name &rest body) 266 | ;; (with-gensyms (result end) 267 | ;; `(let* ((,result (list nil)) 268 | ;; (,end ,result)) 269 | ;; (macrolet ((,name (x) 270 | ;; (list 'setq ',end (list 'setcdr ',end (list 'list x))))) 271 | ;; ,@body 272 | ;; (cdr ,result))))) 273 | 274 | (defmacro with-collector (name &rest body) 275 | (with-gensyms (result) 276 | `(let ((,result nil)) 277 | (macrolet ((,name (x) (list 'push x ',result))) 278 | ,@body 279 | (nreverse ,result))))) 280 | 281 | (defun interned-p (symbol) 282 | (and (symbolp symbol) 283 | (eq (intern-soft (symbol-name symbol)) symbol))) 284 | --------------------------------------------------------------------------------