├── .gitignore ├── LICENSE ├── README ├── asdf-operations.clw ├── asdf-operations.lisp ├── clinit.cl ├── clweb-tests.lisp ├── clweb.asd ├── clweb.clw ├── clweb.el ├── clweb.lisp ├── clwebmac.tex ├── rt.lisp └── test.clw /.gitignore: -------------------------------------------------------------------------------- 1 | #### .gitignore file for CLWEB. 2 | 3 | ## Compiled files from various Lisps. 4 | # SBCL, Allegro Common Lisp 5 | *.fasl 6 | # ECL 7 | *.fas 8 | *.o 9 | *.so 10 | # Clisp 11 | *.fas 12 | *.lib 13 | # LispWorks (probably not comprehensive) 14 | *.xfasl 15 | # CCL, nee OpenMCL 16 | *.dfsl 17 | *.pfsl 18 | *.d64fsl 19 | *.p64fsl 20 | *.lx64fsl 21 | *.lx32fsl 22 | *.dx64fsl 23 | *.dx32fsl 24 | *.fx64fsl 25 | *.fx32fsl 26 | *.sx64fsl 27 | *.sx32fsl 28 | *.wx64fsl 29 | *.wx32fsl 30 | # CMUCL (from the CMUCL 20c sources) 31 | *.axpf 32 | *.amd64f 33 | *.hpf 34 | *.pmaxf 35 | *.sgif 36 | *.ppcf 37 | *.rtf 38 | *.eapcf 39 | *.sparcf 40 | *.sse2f 41 | *.x86f 42 | *.bytef 43 | *.lbytef 44 | 45 | ## Compiled Elisp files 46 | *.elc 47 | 48 | ## TeX outputs. 49 | *.idx 50 | *.scn 51 | *.aux 52 | *.log 53 | *.toc 54 | *.dvi 55 | *.pdf 56 | 57 | ## CLWEB's own outputs 58 | /*.tex 59 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Alexander F. Plotnick 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without restriction, 6 | including without limitation the rights to use, copy, modify, merge, 7 | publish, distribute, sublicense, and/or sell copies of the Software, 8 | and to permit persons to whom the Software is furnished to do so, 9 | subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is CLWEB, a literate programming system for Common Lisp. This file 2 | describes how to get started with CLWEB; it is not a user manual or an 3 | introduction to literate programming in general. A full user manual is 4 | forthcoming; in the meantime, please see the CWEB user manual by Knuth 5 | and Levy, or Knuth's "Literate Programming" (CSLI: 1992). 6 | 7 | In the examples that follow, a dollar sign ($) represents a Unix shell 8 | prompt, and a star (*) represents a Lisp prompt. 9 | 10 | The first thing to do is to compile and load the CLWEB system: 11 | 12 | $ lisp 13 | * (compile-file "clweb") 14 | ; compiling file "/home/alex/src/clweb/clweb.lisp" 15 | ; [compilation messages elided] 16 | #P"/home/alex/src/clweb/clweb.fasl" 17 | NIL 18 | NIL 19 | * (load "clweb") 20 | T 21 | * (use-package "CLWEB") 22 | T 23 | 24 | Now suppose you wanted to weave the CLWEB program itself. You might say: 25 | 26 | * (weave "clweb") 27 | ; weaving WEB from #P"clweb.clw" 28 | ; 0 29 | ; *1 2 3 30 | ; *4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 31 | ; *23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 32 | ; 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 33 | ; 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 34 | ; 80 81 82 83 84 85 86 87 88 35 | ; *89 90 91 92 93 94 36 | ; *95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 37 | ; 110 111 112 113 114 115 116 117 118 119 120 121 122 123 38 | ; 124 125 39 | #P"/home/alex/src/clweb/clweb.tex" 40 | * ^Z 41 | $ tex clweb 42 | This is TeX, Version 3.141592 (Web2C 7.5.4) 43 | (./clweb.tex (./clwebmac.tex 44 | (/usr/pkg/share/texmf-dist/tex/plain/base/cwebmac.tex)) *1 [1] *4 [2] [3] 45 | [4] [5] [6] [7] *23 [8] [9] [10] [11] [12] [13] [14] [15] [16] [17] [18] 46 | [19] [20] [21] [22] [23] [24] [25] [26] [27] [28] [29] *89 [30] [31] [32] 47 | *95 [33] [34] [35] [36] [37] [38] [39] [40] [41] [42] ) 48 | Output written on clweb.dvi (42 pages, 137808 bytes). 49 | Transcript written on clweb.log. 50 | $ 51 | 52 | The numbers that WEAVE prints are the section numbers the weaver sees; the 53 | ones preceded by stars are the `starred', or major, sections. TeX also 54 | prints the starred section numbers along with the page numbers in square 55 | brackets. 56 | 57 | To use CLWEB for your own projects, you need to have the file `clwebmac.tex' 58 | somewhere in TeX's search path. One way to do this (on the author's system, 59 | anyway) is to install a copy of or a symlink to the version included in the 60 | distribution in a directory like `~/texmf/tex/plain'; see the documentation 61 | for your TeX distribution for more information, esp. the Kpathsea library. 62 | 63 | The CLWEB tangler can be used in two different ways: to produce a compiled 64 | file that can be used with LOAD, or to load the contents of a CLWEB file 65 | directly into a running Lisp image. In the first case, you would use 66 | TANGLE-FILE: 67 | 68 | * (compile-file "clweb") 69 | ; tangling WEB from #P"clweb.clw" 70 | ; compiling file "/home/alex/src/clweb/clweb.lisp": 71 | ; [compilation messages elided] 72 | #P"/home/alex/src/clweb/clweb.fasl" 73 | NIL 74 | NIL 75 | * 76 | 77 | You should now have a fresh copy of `clweb.lisp' and `clweb.fasl'. You 78 | shouldn't ever edit the former directly; it's only an intermediate file. 79 | 80 | During development, the other mode of tangling is often more useful: 81 | 82 | * (load-web "clweb") 83 | T 84 | * 85 | 86 | The tangled contents of `clweb.clw' have now been loaded directly into the 87 | Lisp environment. 88 | 89 | Currently, CLWEB runs under SBCL, Allegro Common Lisp, and Clozure Common 90 | Lisp. Reports of the experience of attempting to run the system under other 91 | Common Lisp implementations would be welcome, along with any other 92 | questions, bug-reports, patches, comments, or suggestions; please email 93 | them to Alex Plotnick . 94 | 95 | The author gratefully acknowledges the encouragement and support of Ross 96 | Shaull, who made him believe that at least one other person in the world 97 | thought this might be a good idea, and of Richard Kreuter, for his many 98 | suggestions for improving both the commentary and code of the system, as 99 | well as for his work on SBCL. 100 | -------------------------------------------------------------------------------- /asdf-operations.clw: -------------------------------------------------------------------------------- 1 | % -*-CLWEB-*- 2 | \noinx 3 | \font\sc=cmcsc10 4 | \def\asdf{{\sc asdf}} 5 | \def\CLWEB{{\tt CLWEB}} 6 | 7 | @1*ASDF operations on webs. ``Another System Definition Facility'' (\asdf) 8 | has become the de~facto standard system construction tool for Common Lisp. 9 | Despite its many flaws, it plays an important r\^ole in the modern Common Lisp 10 | ecosystem, and it's handy to be able to use it with \CLWEB. 11 | @^\asdf@> 12 | @^\CLWEB@> 13 | @^Common Lisp@> 14 | 15 | @l 16 | @e (defpackage "CLWEB/ASDF" (:use "COMMON-LISP" "CLWEB" "ASDF")) 17 | @e (in-package "CLWEB/ASDF") 18 | 19 | @ \asdf\ was designed to be extensible, so adding basic support 20 | for webs as first-class components is straightforward. We define 21 | a class for webs as source files, and add specialized methods for 22 | the compile and load operations. 23 | 24 | The class name |clweb-file| is exported by the \CLWEB\ package. 25 | @^\CLWEB@> 26 | @^tangle@> 27 | 28 | @l 29 | (defclass clweb-file (source-file) 30 | ((type :initform (pathname-type *web-pathname-defaults*)))) 31 | 32 | (defmethod component-pathname ((component clweb-file)) 33 | (input-file-pathname (call-next-method))) 34 | 35 | (defmethod output-files ((op compile-op) (component clweb-file)) 36 | (values (multiple-value-list ; 37 | (tangle-file-pathnames (component-pathname component))) 38 | nil)) 39 | 40 | (defmethod perform ((op compile-op) (component clweb-file)) 41 | (tangle-file (component-pathname component) 42 | :output-file (first (output-files op component)))) 43 | 44 | (defmethod perform ((op load-op) (component clweb-file)) 45 | (map nil #'load 46 | (remove-if (lambda (file) ; 47 | (string= (pathname-type file) ; 48 | (pathname-type *lisp-pathname-defaults*))) 49 | (input-files op component)))) 50 | 51 | (defmethod perform ((op load-source-op) (component clweb-file)) 52 | (load-web (component-pathname component))) 53 | 54 | @ We also define a new \asdf\ operation, |weave-op|, which weaves a web. 55 | It has no effect on any other components. 56 | @^weave@> 57 | 58 | @l 59 | (defclass weave-op (downward-operation) ()) 60 | 61 | (defmethod output-files ((op weave-op) (component clweb-file)) 62 | (values (multiple-value-list ; 63 | (weave-pathnames (component-pathname component))) 64 | t)) 65 | 66 | (defmethod perform ((op weave-op) (component clweb-file)) 67 | (weave (component-pathname component))) 68 | -------------------------------------------------------------------------------- /asdf-operations.lisp: -------------------------------------------------------------------------------- 1 | ;;;; TANGLED WEB FROM "asdf-operations.clw". DO NOT EDIT. 2 | #+ALLEGRO 3 | (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL) 4 | (SETQ EXCL:*SOURCE-PATHNAME* #P"asdf-operations.clw")) 5 | 6 | (DEFPACKAGE "CLWEB/ASDF" 7 | (:USE "COMMON-LISP" "CLWEB" "ASDF")) 8 | (IN-PACKAGE "CLWEB/ASDF") 9 | (DEFCLASS CLWEB-FILE (SOURCE-FILE) 10 | ((TYPE :INITFORM (PATHNAME-TYPE *WEB-PATHNAME-DEFAULTS*)))) 11 | (DEFMETHOD COMPONENT-PATHNAME ((COMPONENT CLWEB-FILE)) 12 | (INPUT-FILE-PATHNAME (CALL-NEXT-METHOD))) 13 | (DEFMETHOD OUTPUT-FILES ((OP COMPILE-OP) (COMPONENT CLWEB-FILE)) 14 | (VALUES 15 | (MULTIPLE-VALUE-LIST (TANGLE-FILE-PATHNAMES (COMPONENT-PATHNAME COMPONENT))) 16 | NIL)) 17 | (DEFMETHOD PERFORM ((OP COMPILE-OP) (COMPONENT CLWEB-FILE)) 18 | (TANGLE-FILE (COMPONENT-PATHNAME COMPONENT) :OUTPUT-FILE 19 | (FIRST (OUTPUT-FILES OP COMPONENT)))) 20 | (DEFMETHOD PERFORM ((OP LOAD-OP) (COMPONENT CLWEB-FILE)) 21 | (MAP NIL #'LOAD 22 | (REMOVE-IF 23 | (LAMBDA (FILE) 24 | (STRING= (PATHNAME-TYPE FILE) 25 | (PATHNAME-TYPE *LISP-PATHNAME-DEFAULTS*))) 26 | (INPUT-FILES OP COMPONENT)))) 27 | (DEFMETHOD PERFORM ((OP LOAD-SOURCE-OP) (COMPONENT CLWEB-FILE)) 28 | (LOAD-WEB (COMPONENT-PATHNAME COMPONENT))) 29 | (DEFCLASS WEAVE-OP (DOWNWARD-OPERATION) NIL) 30 | (DEFMETHOD OUTPUT-FILES ((OP WEAVE-OP) (COMPONENT CLWEB-FILE)) 31 | (VALUES 32 | (MULTIPLE-VALUE-LIST (WEAVE-PATHNAMES (COMPONENT-PATHNAME COMPONENT))) T)) 33 | (DEFMETHOD PERFORM ((OP WEAVE-OP) (COMPONENT CLWEB-FILE)) 34 | (WEAVE (COMPONENT-PATHNAME COMPONENT))) -------------------------------------------------------------------------------- /clinit.cl: -------------------------------------------------------------------------------- 1 | ;;;; Initialization forms for CLWEB with Allegro Common -*-Lisp-*- 2 | 3 | (require "CLWEB") 4 | 5 | (defun filename (x) 6 | "Try to coerce X into a pathname." 7 | (etypecase x 8 | (string (parse-namestring x)) 9 | ;; FIXME: We need to do better with case here. 10 | (symbol (parse-namestring (string-downcase (string x)))) 11 | (pathname x))) 12 | 13 | (defmacro make-cached-command (command &aux (cached-args (gensym))) 14 | `(let ((,cached-args nil)) 15 | (lambda (&rest args) 16 | (when args (setq ,cached-args args)) 17 | (apply ,command ,cached-args)))) 18 | 19 | (defmacro alias-cached-command (name command &optional doc-string &aux 20 | (symbol (gensym)) name-string abbr arg-mode) 21 | ;; Parse the NAME argument in the same way that TOP-LEVEL:ALIAS does. 22 | (etypecase name 23 | (string (setq name-string name)) 24 | (list (setq name-string (pop name)) 25 | (dolist (x name) 26 | (etypecase x 27 | (integer (setq abbr x)) 28 | (keyword (setq arg-mode x)))))) 29 | `(progn 30 | (setf (symbol-function ',symbol) 31 | (make-cached-command (symbol-function ',command)) 32 | (documentation ',symbol 'function) 33 | (documentation ',command 'function)) 34 | ;; Yes, Virginia, we're using an internal symbol of the TOP-LEVEL 35 | ;; package. But the public API doesn't allow us to set a doc-string 36 | ;; for a command programmatically, so we're forced to resort to this. 37 | (top-level::add-alias ,name-string (or ,abbr (1- (length ,name-string))) 38 | ',symbol ,doc-string ,arg-mode))) 39 | 40 | (defun tex-command (file) 41 | "Run TeX on FILE." 42 | (excl:shell (format nil "tex ~A" (file-namestring (filename file))))) 43 | 44 | (defun load-web-command (file &rest args) 45 | "Load the web in FILE." 46 | (handler-bind ((warning #'muffle-warning)) 47 | (apply 'clweb:load-web (filename file) args))) 48 | 49 | (defun tangle-file-command (file &rest args) 50 | "Tangle the web in FILE." 51 | (handler-bind ((warning #'muffle-warning)) 52 | (apply 'clweb:tangle-file (filename file) args))) 53 | 54 | (defun weave-command (file &rest args) 55 | "Weave the web in FILE." 56 | (apply 'clweb:weave (filename file) args)) 57 | 58 | (alias-cached-command "tex" tex-command "run TeX") 59 | (alias-cached-command "tf" tangle-file-command "tangle file") 60 | (alias-cached-command "lw" load-web-command "load web") 61 | (alias-cached-command ("weave" 1) weave-command "weave web") 62 | 63 | ;;; Testing aliases. 64 | 65 | (require "RT") 66 | 67 | (top-level:alias "dt" () "do tests" (rt:do-tests)) 68 | (top-level:alias "ct" () "continue testing" (rt:continue-testing)) 69 | 70 | (defun tangle-test-command (file &rest args &aux (file (filename file))) 71 | "Tangle FILE, load the compiled file, and run the tests." 72 | (and (load (apply #'tangle-file-command file args)) 73 | (progn 74 | (rt:rem-all-tests) 75 | (load (clweb::tests-file-pathname file nil))) 76 | (rt:do-tests))) 77 | 78 | (alias-cached-command "tt" tangle-test-command "tangle & test") 79 | -------------------------------------------------------------------------------- /clweb-tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; TANGLED WEB FROM "clweb.clw". DO NOT EDIT. 2 | 3 | (IN-PACKAGE "CLWEB") 4 | (DEFMACRO DEFTEST (NAME FORM &REST VALUES) `(RT:DEFTEST ,NAME ,FORM ,@VALUES)) 5 | (DEFTEST MAYBE-PUSH 6 | (LET ((LIST 'NIL)) 7 | (MAYBE-PUSH 'A LIST) 8 | (MAYBE-PUSH NIL LIST) 9 | (MAYBE-PUSH 'B LIST) 10 | (MAYBE-PUSH "" LIST) 11 | (MAYBE-PUSH "foo" LIST) 12 | (NREVERSE LIST)) 13 | (A B "foo")) 14 | (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) 15 | (SETF (LOGICAL-PATHNAME-TRANSLATIONS "clweb-test") '(("**;*.*.*" "")))) 16 | (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) 17 | (DEFUN PHYSICAL-PATHNAME-OR-NULL (PATHSPEC) 18 | (AND PATHSPEC (TRANSLATE-LOGICAL-PATHNAME PATHSPEC)))) 19 | (DEFMACRO WITH-PATHNAME-TEST-VARIABLES (&BODY BODY &AUX (FIX-LPN (GENSYM))) 20 | `(FLET ((,FIX-LPN (LPN) 21 | (MAKE-PATHNAME :DEFAULTS LPN :DIRECTORY NIL :NAME NIL))) 22 | (PROGV 23 | '(*WEB-PATHNAME-DEFAULTS* *LISP-PATHNAME-DEFAULTS* 24 | *TEX-PATHNAME-DEFAULTS* *INDEX-PATHNAME-DEFAULTS* 25 | *SECTIONS-PATHNAME-DEFAULTS*) 26 | (MAPCAR #',FIX-LPN 27 | '(#P"clweb-test:foo.clw.newest" #P"clweb-test:foo.lisp.newest" 28 | #P"clweb-test:foo.tex.newest" #P"clweb-test:foo.idx.newest" 29 | #P"clweb-test:foo.scn.newest")) 30 | ,@BODY))) 31 | (DEFMACRO DEFINE-PATHNAME-TEST (NAME FORM &REST EXPECTED-VALUES) 32 | (WITH-UNIQUE-NAMES (VALUES) 33 | `(DEFTEST ,NAME 34 | (WITH-PATHNAME-TEST-VARIABLES 35 | (LET* ((*DEFAULT-PATHNAME-DEFAULTS* #P"clweb-test:") 36 | (,VALUES (MULTIPLE-VALUE-LIST ,FORM))) 37 | (VALUES-LIST (MAPCAR #'PHYSICAL-PATHNAME-OR-NULL ,VALUES)))) 38 | ,@(MAPCAR #'PHYSICAL-PATHNAME-OR-NULL EXPECTED-VALUES)))) 39 | (DEFINE-PATHNAME-TEST INPUT-FILE-PATHNAME 40 | (VALUES (INPUT-FILE-PATHNAME #P"clweb-test:foo") 41 | (INPUT-FILE-PATHNAME #P"clweb-test:foo.in")) 42 | #P"clweb-test:foo.clw.newest" #P"clweb-test:foo.in.newest") 43 | (DEFINE-PATHNAME-TEST OUTPUT-FILE-PATHNAME 44 | (VALUES (IGNORE-ERRORS (OUTPUT-FILE-PATHNAME #P"clweb-test:foo")) 45 | (OUTPUT-FILE-PATHNAME #P"clweb-test:foo" :DEFAULTS 46 | *LISP-PATHNAME-DEFAULTS*) 47 | (OUTPUT-FILE-PATHNAME #P"clweb-test:foo" :OUTPUT-FILE 48 | #P"clweb-test:bar" :DEFAULTS 49 | *LISP-PATHNAME-DEFAULTS*) 50 | (OUTPUT-FILE-PATHNAME #P"clweb-test:foo" :OUTPUT-FILE 51 | #P"clweb-test:bar.baz" :DEFAULTS 52 | *LISP-PATHNAME-DEFAULTS*)) 53 | NIL #P"clweb-test:foo.lisp.newest" #P"clweb-test:bar.lisp.newest" 54 | #P"clweb-test:bar.baz.newest") 55 | (DEFTEST (OUTPUT-FILE-PATHNAME VERSION :NEWEST) 56 | (PATHNAME-VERSION 57 | (OUTPUT-FILE-PATHNAME #P"clweb-test:foo.clw.1" :DEFAULTS 58 | *LISP-PATHNAME-DEFAULTS*)) 59 | #-:ALLEGRO :newest #+:ALLEGRO :unspecific) 60 | (DEFTEST (OUTPUT-FILE-PATHNAME VERSION OUTPUT-FILE) 61 | (PATHNAME-VERSION 62 | (OUTPUT-FILE-PATHNAME #P"clweb-test:foo.clw.1" :OUTPUT-FILE 63 | #P"clweb-test:foo.clw.2" :DEFAULTS 64 | *LISP-PATHNAME-DEFAULTS*)) 65 | #-:ALLEGRO 2 #+:ALLEGRO :unspecific) 66 | (DEFINE-PATHNAME-TEST LISP-FILE-PATHNAME 67 | (LISP-FILE-PATHNAME #P"clweb-test:foo") #P"clweb-test:foo.lisp.newest") 68 | (DEFINE-PATHNAME-TEST TEX-FILE-PATHNAME (TEX-FILE-PATHNAME #P"clweb-test:foo") 69 | #P"clweb-test:foo.tex.newest") 70 | (DEFINE-PATHNAME-TEST INDEX-FILE-PATHNAME 71 | (INDEX-FILE-PATHNAME #P"clweb-test:foo") #P"clweb-test:foo.idx.newest") 72 | (DEFINE-PATHNAME-TEST SECTIONS-FILE-PATHNAME 73 | (SECTIONS-FILE-PATHNAME #P"clweb-test:foo") #P"clweb-test:foo.scn.newest") 74 | (DEFINE-PATHNAME-TEST FASL-FILE-PATHNAME 75 | (FASL-FILE-PATHNAME #P"clweb-test:foo") 76 | #.(COMPILE-FILE-PATHNAME #P"clweb-test:foo.lisp.newest")) 77 | (DEFINE-PATHNAME-TEST (TESTS-FILE-PATHNAME 1) 78 | (TESTS-FILE-PATHNAME #P"clweb-test:foo.clw" :OUTPUT-FILE 79 | #P"clweb-test:foo.lisp" :TESTS-FILE #P"clweb-test:bar") 80 | #P"clweb-test:bar.lisp.newest") 81 | (DEFINE-PATHNAME-TEST (TESTS-FILE-PATHNAME 2) 82 | (TESTS-FILE-PATHNAME #P"clweb-test:foo.clw" :OUTPUT-FILE #P"clweb-test:foo" 83 | :TESTS-FILE NIL) 84 | NIL) 85 | (DEFINE-PATHNAME-TEST (TESTS-FILE-PATHNAME 3) 86 | (TESTS-FILE-PATHNAME #P"clweb-test:foo.clw" :OUTPUT-FILE 87 | #P"clweb-test:a;b;bar.tex") 88 | #P"clweb-test:a;b;bar-tests.tex.newest") 89 | (DEFINE-PATHNAME-TEST (TANGLE-FILE-PATHNAMES 1) 90 | (TANGLE-FILE-PATHNAMES #P"clweb-test:foo") 91 | #.(COMPILE-FILE-PATHNAME #P"clweb-test:foo.lisp.newest") 92 | #P"clweb-test:foo.lisp.newest" 93 | #.(COMPILE-FILE-PATHNAME #P"clweb-test:foo-tests.lisp.newest") 94 | #P"clweb-test:foo-tests.lisp.newest") 95 | (DEFINE-PATHNAME-TEST (TANGLE-FILE-PATHNAMES 2) 96 | (LET* ((INPUT-FILE #P"clweb-test:foo") 97 | (FASL-TYPE (PATHNAME-TYPE (COMPILE-FILE-PATHNAME INPUT-FILE))) 98 | (OUTPUT-FILE 99 | (MAKE-PATHNAME :TYPE FASL-TYPE :DEFAULTS #P"clweb-test:a;b;bar"))) 100 | (TANGLE-FILE-PATHNAMES INPUT-FILE :OUTPUT-FILE OUTPUT-FILE)) 101 | #.(COMPILE-FILE-PATHNAME #P"clweb-test:a;b;bar.lisp.newest") 102 | #P"clweb-test:a;b;bar.lisp.newest" 103 | #.(COMPILE-FILE-PATHNAME #P"clweb-test:a;b;bar-tests.lisp.newest") 104 | #P"clweb-test:a;b;bar-tests.lisp.newest") 105 | (DEFINE-PATHNAME-TEST (TANGLE-FILE-PATHNAMES 3) 106 | (TANGLE-FILE-PATHNAMES #P"clweb-test:foo" :TESTS-FILE NIL) 107 | #.(COMPILE-FILE-PATHNAME #P"clweb-test:foo.lisp.newest") 108 | #P"clweb-test:foo.lisp.newest" NIL NIL) 109 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO) 110 | (WEAVE-PATHNAMES #P"clweb-test:foo") #P"clweb-test:foo.tex.newest" 111 | #P"clweb-test:foo.idx.newest" #P"clweb-test:foo.scn.newest") 112 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO.BAR) 113 | (WEAVE-PATHNAMES #P"clweb-test:foo.bar") #P"clweb-test:foo.tex.newest" 114 | #P"clweb-test:foo.idx.newest" #P"clweb-test:foo.scn.newest") 115 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO :OUTPUT-FILE T) 116 | (WEAVE-PATHNAMES #P"clweb-test:foo" :OUTPUT-FILE 117 | #P"clweb-test:a;bar.baz.newest") 118 | #P"clweb-test:a;bar.baz.newest" #P"clweb-test:a;bar.idx.newest" 119 | #P"clweb-test:a;bar.scn.newest") 120 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO :OUTPUT-FILE BAR) 121 | (WEAVE-PATHNAMES #P"clweb-test:foo" :OUTPUT-FILE #P"clweb-test:bar") 122 | #P"clweb-test:bar.tex.newest" #P"clweb-test:bar.idx.newest" 123 | #P"clweb-test:bar.scn.newest") 124 | (DEFTEST (WEAVE-PATHNAMES FOO :OUTPUT-FILE BAR.T) 125 | (PATHNAME-TYPE 126 | (WEAVE-PATHNAMES #P"clweb-test:foo" :OUTPUT-FILE #P"clweb-test:bar.t") :CASE 127 | :COMMON) 128 | "T") 129 | #-:ALLEGRO 130 | (deftest (weave-pathnames foo :output-file (:type :unspecific)) 131 | (pathname-type 132 | (weave-pathnames #P"clweb-test:foo" ; 133 | :output-file (make-pathname :host "clweb-test" ; 134 | :type :unspecific))) 135 | :unspecific) 136 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO :INDEX-FILE NIL) 137 | (WEAVE-PATHNAMES #P"clweb-test:foo" :INDEX-FILE NIL) 138 | #P"clweb-test:foo.tex.newest" NIL NIL) 139 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO :INDEX-FILE BAR) 140 | (WEAVE-PATHNAMES #P"clweb-test:foo" :INDEX-FILE #P"clweb-test:bar") 141 | #P"clweb-test:foo.tex.newest" #P"clweb-test:bar.idx.newest" 142 | #P"clweb-test:bar.scn.newest") 143 | (DEFINE-PATHNAME-TEST (WEAVE-PATHNAMES FOO :OUTPUT-FILE T :INDEX-FILE T) 144 | (WEAVE-PATHNAMES #P"clweb-test:foo" :OUTPUT-FILE 145 | #P"clweb-test:a;bar.tex.newest" :INDEX-FILE 146 | #P"clweb-test:b;index.idx.newest") 147 | #P"clweb-test:a;bar.tex.newest" #P"clweb-test:b;index.idx.newest" 148 | #P"clweb-test:b;index.scn.newest") 149 | (DEFMETHOD SECTION-NUMBER ((SECTION INTEGER)) SECTION) 150 | (DEFTEST CURRENT-SECTION 151 | (LET ((*SECTIONS* (MAKE-ARRAY 1 :FILL-POINTER 0))) 152 | (EQL (MAKE-INSTANCE 'SECTION) *CURRENT-SECTION*)) 153 | T) 154 | (DEFMACRO WITH-TEMPORARY-SECTIONS (SECTIONS &BODY BODY) 155 | (WITH-UNIQUE-NAMES (SPEC SECTION NAME) 156 | `(LET ((*SECTIONS* (MAKE-ARRAY 16 :ADJUSTABLE T :FILL-POINTER 0)) 157 | (*TEST-SECTIONS* (MAKE-ARRAY 16 :ADJUSTABLE T :FILL-POINTER 0)) 158 | (*NAMED-SECTIONS* NIL)) 159 | (DOLIST (,SPEC ,SECTIONS) 160 | (LET* ((,SECTION 161 | (APPLY #'MAKE-INSTANCE 162 | (ECASE (POP ,SPEC) 163 | (:SECTION 'SECTION) 164 | (:STARRED-SECTION 'STARRED-SECTION) 165 | (:LIMBO 'LIMBO-SECTION)) 166 | ,SPEC)) 167 | (,NAME (SECTION-NAME ,SECTION))) 168 | (WHEN ,NAME 169 | (PUSH ,SECTION (NAMED-SECTION-SECTIONS (FIND-SECTION ,NAME)))))) 170 | ,@BODY))) 171 | (DEFTEST (BST SIMPLE) 172 | (LET ((TREE (MAKE-INSTANCE 'BINARY-SEARCH-TREE :KEY 0))) 173 | (FIND-OR-INSERT -1 TREE) 174 | (FIND-OR-INSERT 1 TREE) 175 | (VALUES (NODE-KEY TREE) (NODE-KEY (LEFT-CHILD TREE)) 176 | (NODE-KEY (RIGHT-CHILD TREE)))) 177 | 0 -1 1) 178 | (DEFTEST (BST RANDOM) 179 | (LET ((TREE (MAKE-INSTANCE 'BINARY-SEARCH-TREE :KEY 0)) 180 | (NUMBERS 181 | (CONS 0 182 | (LOOP WITH LIMIT = 1000 183 | FOR I FROM 1 TO LIMIT 184 | COLLECT (RANDOM LIMIT))))) 185 | (DOLIST (N NUMBERS) (FIND-OR-INSERT N TREE)) 186 | (LET ((KEYS 'NIL)) 187 | (FLET ((PUSH-KEY (NODE) 188 | (PUSH (NODE-KEY NODE) KEYS))) 189 | (MAP-BST #'PUSH-KEY TREE) 190 | (EQUAL (NREVERSE KEYS) (REMOVE-DUPLICATES (SORT NUMBERS #'<)))))) 191 | T) 192 | (DEFTEST (BST FIND-NO-INSERT) 193 | (LET ((TREE (MAKE-INSTANCE 'BINARY-SEARCH-TREE :KEY 0))) 194 | (FIND-OR-INSERT -1 TREE :INSERT-IF-NOT-FOUND NIL)) 195 | NIL NIL) 196 | (DEFTEST NAMED-SECTION-NUMBER/CODE 197 | (WITH-TEMPORARY-SECTIONS 198 | '((:SECTION :NAME "foo" :CODE (1)) (:SECTION :NAME "foo" :CODE (2)) 199 | (:SECTION :NAME "foo" :CODE (3))) 200 | (LET ((SECTION (FIND-SECTION "foo"))) 201 | (VALUES (SECTION-CODE SECTION) (SECTION-NUMBER SECTION)))) 202 | (1 2 3) 0) 203 | (DEFTEST UNDEFINED-NAMED-SECTION 204 | (HANDLER-CASE (SECTION-NUMBER (MAKE-INSTANCE 'NAMED-SECTION :NAME "foo")) 205 | (UNDEFINED-NAMED-SECTION-ERROR NIL :ERROR)) 206 | :ERROR) 207 | (DEFTEST (SECTION-NAME-PREFIX-P 1) (SECTION-NAME-PREFIX-P "a") NIL 1) 208 | (DEFTEST (SECTION-NAME-PREFIX-P 2) (SECTION-NAME-PREFIX-P "ab...") T 2) 209 | (DEFTEST (SECTION-NAME-PREFIX-P 3) (SECTION-NAME-PREFIX-P "abcd...") T 4) 210 | (DEFTEST (SECTION-NAME-LESSP 1) (SECTION-NAME-LESSP "b" "a") NIL) 211 | (DEFTEST (SECTION-NAME-LESSP 2) (SECTION-NAME-LESSP "b..." "a...") NIL) 212 | (DEFTEST (SECTION-NAME-LESSP 3) (SECTION-NAME-LESSP "ab" "a...") NIL) 213 | (DEFTEST (SECTION-NAME-EQUAL 1) (SECTION-NAME-EQUAL "a" "b") NIL) 214 | (DEFTEST (SECTION-NAME-EQUAL 2) (SECTION-NAME-EQUAL "a" "a") T) 215 | (DEFTEST (SECTION-NAME-EQUAL 3) (SECTION-NAME-EQUAL "a..." "ab") T) 216 | (DEFTEST (SECTION-NAME-EQUAL 4) (SECTION-NAME-EQUAL "a..." "ab...") T) 217 | (DEFTEST (SQUEEZE 1) (SQUEEZE "abc") "abc") 218 | (DEFTEST (SQUEEZE 2) (SQUEEZE "ab c") "ab c") 219 | (DEFTEST (SQUEEZE 3) (SQUEEZE (FORMAT NIL " a b ~C c " #\Tab)) "a b c") 220 | (DEFVAR *SAMPLE-NAMED-SECTIONS* 221 | (WITH-TEMPORARY-SECTIONS 222 | '((:SECTION :NAME "foo" :CODE (:FOO)) (:SECTION :NAME "bar" :CODE (:BAR)) 223 | (:SECTION :NAME "baz" :CODE (:BAZ)) 224 | (:SECTION :NAME "quux" :CODE (:QUUX :QUUUX :QUUUUX))) 225 | *NAMED-SECTIONS*)) 226 | (DEFMACRO WITH-SAMPLE-NAMED-SECTIONS (&BODY BODY) 227 | `(LET ((*NAMED-SECTIONS* *SAMPLE-NAMED-SECTIONS*)) 228 | ,@BODY)) 229 | (DEFUN FIND-SAMPLE-SECTION (NAME) 230 | (FIND-OR-INSERT NAME *SAMPLE-NAMED-SECTIONS* :INSERT-IF-NOT-FOUND NIL)) 231 | (DEFTEST FIND-NAMED-SECTION (SECTION-NAME (FIND-SAMPLE-SECTION "foo")) "foo") 232 | (DEFTEST FIND-SECTION-BY-PREFIX (SECTION-NAME (FIND-SAMPLE-SECTION "f...")) 233 | "foo") 234 | (DEFTEST FIND-SECTION-BY-AMBIGUOUS-PREFIX 235 | (LET ((HANDLED NIL)) 236 | (VALUES 237 | (SECTION-NAME 238 | (HANDLER-BIND ((AMBIGUOUS-PREFIX-ERROR 239 | (LAMBDA (CONDITION) 240 | (DECLARE (IGNORE CONDITION)) 241 | (SETQ HANDLED T) 242 | (INVOKE-RESTART 'USE-FIRST-MATCH)))) 243 | (FIND-SAMPLE-SECTION "b..."))) 244 | HANDLED)) 245 | "bar" T) 246 | (DEFTEST FIND-SECTION 247 | (WITH-SAMPLE-NAMED-SECTIONS 248 | (FIND-SECTION (FORMAT NIL " foo bar ~C baz..." #\Tab)) 249 | (SECTION-NAME (FIND-SECTION "foo..."))) 250 | "foo") 251 | (DEFTEST (READTABLE-FOR-MODE 1) (READTABLEP (READTABLE-FOR-MODE :TEX)) T) 252 | (DEFTEST (READTABLE-FOR-MODE 2) (READTABLEP (READTABLE-FOR-MODE NIL)) T) 253 | (DEFTEST (READTABLE-FOR-MODE 3) 254 | (EQL (READTABLE-FOR-MODE :TEX) (READTABLE-FOR-MODE :LISP)) NIL) 255 | (DEFTEST WITH-MODE 256 | (LOOP FOR (MODE . READTABLE) IN *READTABLES* 257 | ALWAYS (WITH-MODE MODE 258 | (EQL *READTABLE* READTABLE))) 259 | T) 260 | (DEFTEST EOF-P (EOF-P (READ-FROM-STRING "" NIL EOF)) T) 261 | (DEFTEST EOF-TYPE (TYPEP (READ-FROM-STRING "" NIL EOF) 'EOF) T) 262 | (DEFTEST (TOKEN-DELIMITER-P 1) (NOT (TOKEN-DELIMITER-P #\ )) NIL) 263 | (DEFTEST (TOKEN-DELIMITER-P 2) (NOT (TOKEN-DELIMITER-P #\))) NIL) 264 | (DEFTEST (READ-MAYBE-NOTHING 1) 265 | (WITH-INPUT-FROM-STRING (S "123") (READ-MAYBE-NOTHING S)) (123)) 266 | (DEFTEST (READ-MAYBE-NOTHING 2) 267 | (LET ((*READTABLE* (COPY-READTABLE NIL))) 268 | (SET-MACRO-CHARACTER #\! 269 | (WRAP-READER-MACRO-FUNCTION 270 | (LAMBDA (STREAM CHAR) 271 | (DECLARE (IGNORE STREAM CHAR)) 272 | (VALUES)))) 273 | (WITH-INPUT-FROM-STRING (S "!") (READ-MAYBE-NOTHING S))) 274 | NIL) 275 | (DEFTEST READ-MAYBE-NOTHING-PRESERVING-WHITESPACE 276 | (WITH-INPUT-FROM-STRING (S "x y") 277 | (READ-MAYBE-NOTHING-PRESERVING-WHITESPACE S T NIL NIL) 278 | (PEEK-CHAR NIL S)) 279 | #\ ) 280 | (DEFTEST CHARPOS-INPUT-STREAM 281 | (LET ((*TAB-WIDTH* 8)) 282 | (WITH-CHARPOS-INPUT-STREAM (S 283 | (MAKE-STRING-INPUT-STREAM 284 | (FORMAT NIL "012~%abc~C~C" #\Tab #\Tab))) 285 | (VALUES (STREAM-CHARPOS S) (READ-LINE S) (STREAM-CHARPOS S) (READ-CHAR S) 286 | (READ-CHAR S) (READ-CHAR S) (STREAM-CHARPOS S) (READ-CHAR S) 287 | (STREAM-CHARPOS S) (READ-CHAR S) (STREAM-CHARPOS S)))) 288 | 0 "012" 0 #\a #\b #\c 3 #\Tab 8 #\Tab 16) 289 | (DEFTEST CHARPOS-OUTPUT-STREAM 290 | (LET ((STRING-STREAM (MAKE-STRING-OUTPUT-STREAM))) 291 | (WITH-CHARPOS-OUTPUT-STREAM (S STRING-STREAM) 292 | (VALUES (STREAM-CHARPOS S) 293 | (PROGN (WRITE-STRING "012" S) (STREAM-CHARPOS S)) 294 | (PROGN (WRITE-CHAR #\Newline S) (STREAM-CHARPOS S)) 295 | (PROGN (WRITE-STRING "abc" S) (STREAM-CHARPOS S)) 296 | (GET-OUTPUT-STREAM-STRING STRING-STREAM)))) 297 | 0 3 0 3 #.(FORMAT NIL "012~%abc")) 298 | (DEFTEST REWIND-STREAM 299 | (WITH-INPUT-FROM-STRING (S "abcdef") 300 | (WITH-REWIND-STREAM (R S) 301 | (VALUES (READ-CHAR R) (READ-CHAR R) (READ-CHAR R) 302 | (PROGN (REWIND) (READ-CHAR R)) (PROGN (REWIND) (READ-LINE R))))) 303 | #\a #\b #\c #\a "bcdef") 304 | (DEFTEST (READ-WITH-ECHO EOF) 305 | (WITH-INPUT-FROM-STRING (STREAM ":foo") 306 | (READ-WITH-ECHO (STREAM OBJECT CHARS) 307 | (VALUES OBJECT CHARS))) 308 | :FOO ":foo") 309 | (DEFTEST (READ-WITH-ECHO SPACE) 310 | (WITH-INPUT-FROM-STRING (STREAM ":foo :bar") 311 | (READ-WITH-ECHO (STREAM OBJECT CHARS) 312 | (VALUES OBJECT CHARS))) 313 | :FOO ":foo") 314 | (DEFTEST (READ-WITH-ECHO STRING) 315 | (WITH-INPUT-FROM-STRING (STREAM "\"foo\" :bar") 316 | (READ-WITH-ECHO (STREAM OBJECT CHARS) 317 | (VALUES OBJECT CHARS))) 318 | "foo" "\"foo\"") 319 | (DEFTEST (READ-WITH-ECHO PAREN) 320 | (WITH-INPUT-FROM-STRING (STREAM ":foo)") 321 | (READ-WITH-ECHO (STREAM OBJECT CHARS) 322 | (VALUES OBJECT CHARS))) 323 | :FOO ":foo") 324 | (DEFTEST (READ-WITH-ECHO VECTOR) 325 | (WITH-INPUT-FROM-STRING (STREAM "#(1 2 3) :foo") 326 | (READ-WITH-ECHO (STREAM OBJECT CHARS) 327 | (VALUES OBJECT CHARS))) 328 | #(1 2 3) "#(1 2 3)") 329 | (DEFTEST PRINT-MARKER 330 | (WRITE-TO-STRING (MAKE-INSTANCE 'MARKER :VALUE :FOO) :PPRINT-DISPATCH 331 | *TANGLE-PPRINT-DISPATCH* :PRETTY T) 332 | ":FOO") 333 | (DEFMETHOD PRINT-OBJECT ((OBJ MARKER) STREAM) 334 | (PRINT-UNREADABLE-OBJECT (OBJ STREAM :TYPE T :IDENTITY T) 335 | (WHEN (MARKER-BOUNDP OBJ) (PRINC (MARKER-VALUE OBJ) STREAM)))) 336 | (DEFTEST PRINT-MARKER-UNREADABLY 337 | (LET ((*PRINT-READABLY* T)) 338 | (HANDLER-CASE (FORMAT NIL "~W" (MAKE-INSTANCE 'MARKER :VALUE :FOO)) 339 | (PRINT-NOT-READABLE (CONDITION) 340 | (MARKER-VALUE (PRINT-NOT-READABLE-OBJECT CONDITION))))) 341 | :FOO) 342 | (DEFTEST READ-NEWLINE 343 | (NEWLINEP 344 | (WITH-INPUT-FROM-STRING (S (FORMAT NIL "~%")) 345 | (WITH-MODE :LISP 346 | (READ S)))) 347 | T) 348 | (DEFTEST READ-PAR 349 | (TYPEP 350 | (WITH-INPUT-FROM-STRING (S (FORMAT NIL "~%~%")) 351 | (WITH-MODE :LISP 352 | (READ S))) 353 | 'PAR-MARKER) 354 | T) 355 | (DEFMACRO READ-FROM-STRING-WITH-CHARPOS 356 | (STRING &OPTIONAL (EOF-ERROR-P T) (EOF-VALUE NIL)) 357 | (WITH-UNIQUE-NAMES (STRING-STREAM CHARPOS-STREAM) 358 | `(WITH-OPEN-STREAM (,STRING-STREAM (MAKE-STRING-INPUT-STREAM ,STRING)) 359 | (WITH-CHARPOS-INPUT-STREAM (,CHARPOS-STREAM ,STRING-STREAM) 360 | (READ ,CHARPOS-STREAM ,EOF-ERROR-P ,EOF-VALUE))))) 361 | (DEFUN READ-FORM-FROM-STRING (STRING &KEY (MODE :LISP)) 362 | (LET ((*PACKAGE* (FIND-PACKAGE "CLWEB"))) 363 | (WITH-MODE MODE 364 | (READ-FROM-STRING-WITH-CHARPOS STRING)))) 365 | (DEFTEST (READ-EMPTY-LIST :INNER-LISP) 366 | (TYPEP (READ-FORM-FROM-STRING "()" :MODE :INNER-LISP) 'EMPTY-LIST-MARKER) T) 367 | (DEFTEST (READ-LIST :INNER-LISP) 368 | (LISTP (READ-FORM-FROM-STRING "(:a :b :c)" :MODE :INNER-LISP)) T) 369 | (DEFTEST READ-EMPTY-LIST 370 | (TYPEP (READ-FORM-FROM-STRING "()") 'EMPTY-LIST-MARKER) T) 371 | (DEFMACRO DEFINE-LIST-READER-TEST (NAME STRING EXPECTED-LIST EXPECTED-CHARPOS) 372 | `(DEFTEST ,NAME 373 | (LET* ((MARKER (READ-FORM-FROM-STRING ,STRING)) 374 | (LIST (MARKER-VALUE MARKER)) 375 | (CHARPOS (LIST-MARKER-CHARPOS MARKER))) 376 | (AND (EQUAL LIST ',EXPECTED-LIST) (EQUAL CHARPOS ',EXPECTED-CHARPOS))) 377 | T)) 378 | (DEFINE-LIST-READER-TEST (LIST-READER 1) "(a b c)" (A B C) (1 3 5)) 379 | (DEFINE-LIST-READER-TEST (LIST-READER 2) "(a b . c)" (A B . C) (1 3 5 7)) 380 | (DEFINE-LIST-READER-TEST (LIST-READER 3) "(a b .c)" (A B .C) (1 3 5)) 381 | (DEFINE-LIST-READER-TEST (LIST-READER 4) "(a b #|c|#)" (A B) (1 3)) 382 | (DEFINE-LIST-READER-TEST (LIST-READER 5) "(#|foo|#)" NIL NIL) 383 | (DEFTEST READ-LIST-ERROR 384 | (HANDLER-CASE (READ-FORM-FROM-STRING "(. a)") (READER-ERROR NIL :ERROR)) 385 | :ERROR) 386 | (DEFTEST READ-DOTTED-LIST 387 | (WITH-INPUT-FROM-STRING (STREAM "(foo .(foo))") 388 | (WITH-CHARPOS-INPUT-STREAM (CSTREAM STREAM) 389 | (WITH-MODE :LISP 390 | (READ CSTREAM) 391 | (PEEK-CHAR NIL CSTREAM NIL)))) 392 | NIL) 393 | (DEFTEST READ-QUOTED-FORM 394 | (LET ((MARKER (READ-FORM-FROM-STRING "':foo"))) 395 | (VALUES (QUOTED-FORM MARKER) (MARKER-VALUE MARKER))) 396 | :FOO ':FOO) 397 | (DEFTEST READ-COMMENT 398 | (LET ((MARKER (READ-FORM-FROM-STRING "; foo"))) 399 | (VALUES (COMMENT-TEXT MARKER) (MARKER-BOUNDP MARKER))) 400 | "; foo" NIL) 401 | (DEFTEST READ-EMPTY-COMMENT 402 | (WITH-INPUT-FROM-STRING (S (FORMAT NIL ";~%")) 403 | (WITH-MODE :LISP 404 | (READ-MAYBE-NOTHING S))) 405 | NIL) 406 | (DEFMETHOD PRINT-OBJECT ((OBJECT COMMA) STREAM) 407 | (PRINT-UNREADABLE-OBJECT (OBJECT STREAM) 408 | (FORMAT STREAM ",~@[~C~]~S" (COMMA-MODIFIER OBJECT) (COMMA-FORM OBJECT)))) 409 | (DEFTEST (BQ 1) 410 | (LET ((B 3)) 411 | (DECLARE (SPECIAL B)) 412 | (EQUAL (EVAL (TANGLE (READ-FORM-FROM-STRING "`(a b ,b ,(+ b 1) b)"))) 413 | '(A B 3 4 B))) 414 | T) 415 | (DEFTEST (BQ 2) 416 | (LET ((X '(A B C))) 417 | (DECLARE (SPECIAL X)) 418 | (EQUAL 419 | (EVAL 420 | (TANGLE 421 | (READ-FORM-FROM-STRING 422 | "`(x ,x ,@x foo ,(cadr x) bar ,(cdr x) baz ,@(cdr x))"))) 423 | '(X (A B C) A B C FOO B BAR (B C) BAZ B C))) 424 | T) 425 | (DEFUN R (X) (REDUCE #'* X)) 426 | (DEFTEST (BQ NESTED) 427 | (LET ((Q '(R S)) (R '(3 5)) (S '(4 6))) 428 | (DECLARE (SPECIAL Q R S)) 429 | (VALUES (EVAL (EVAL (TANGLE (READ-FORM-FROM-STRING "``(,,q)")))) 430 | (EVAL (EVAL (TANGLE (READ-FORM-FROM-STRING "``(,@,q)")))) 431 | (EVAL (EVAL (TANGLE (READ-FORM-FROM-STRING "``(,,@q)")))) 432 | (EVAL (EVAL (TANGLE (READ-FORM-FROM-STRING "``(,@,@q)")))))) 433 | (24) 24 ((3 5) (4 6)) (3 5 4 6)) 434 | (DEFTEST (BQ VECTOR) 435 | (LET ((A '(1 2 3))) 436 | (DECLARE (SPECIAL A)) 437 | (VALUES (EVAL (TANGLE (READ-FORM-FROM-STRING "`#(:a)"))) 438 | (EVAL (TANGLE (READ-FORM-FROM-STRING "`#(\"a\")"))) 439 | (EVAL (TANGLE (READ-FORM-FROM-STRING "`#(,a)"))) 440 | (EVAL (TANGLE (READ-FORM-FROM-STRING "`#(,@a)"))))) 441 | #(:A) #("a") #((1 2 3)) #(1 2 3)) 442 | (DEFTEST (BQ NAMED-SECTION) 443 | (WITH-SAMPLE-NAMED-SECTIONS 444 | (VALUES (EVAL (TANGLE (READ-FORM-FROM-STRING "`(, @)"))) 445 | (EVAL (TANGLE (READ-FORM-FROM-STRING "`(,@ @)"))))) 446 | (:FOO) :FOO) 447 | (DEFTEST (BQ TOO-MANY-FORMS) 448 | (WITH-SAMPLE-NAMED-SECTIONS 449 | (LET ((HANDLED NIL)) 450 | (HANDLER-BIND ((ERROR 451 | (LAMBDA (CONDITION) (SETQ HANDLED T) (CONTINUE CONDITION)))) 452 | (VALUES (EVAL (TANGLE (READ-FORM-FROM-STRING "`(,@ @)"))) 453 | HANDLED)))) 454 | :QUUX T) 455 | (DEFTEST READ-FUNCTION 456 | (LET ((MARKER (READ-FORM-FROM-STRING "#'identity"))) 457 | (VALUES (QUOTED-FORM MARKER) (MARKER-VALUE MARKER))) 458 | IDENTITY #'IDENTITY) 459 | (DEFTEST READ-SIMPLE-VECTOR 460 | (VALUES (MARKER-VALUE (READ-FORM-FROM-STRING "#5(:a :b :c #C(0 1))")) 461 | (MARKER-VALUE (READ-FORM-FROM-STRING "#0()"))) 462 | #(:A :B :C #C(0 1) #C(0 1)) #()) 463 | (DEFTEST READ-BIT-VECTOR (MARKER-VALUE (READ-FORM-FROM-STRING "#6*101")) 464 | #*101111) 465 | (DEFTEST (READ-TIME-EVAL 1) 466 | (LET* ((*READ-EVAL* T) (*EVALUATING* NIL)) 467 | (WRITE-TO-STRING (MARKER-VALUE (READ-FORM-FROM-STRING "#.(+ 1 1)")) 468 | :PPRINT-DISPATCH *TANGLE-PPRINT-DISPATCH* :PRETTY T)) 469 | "#.(+ 1 1)") 470 | (DEFTEST (READ-TIME-EVAL 2) 471 | (LET* ((*READ-EVAL* T) (*EVALUATING* T)) 472 | (MARKER-VALUE (READ-FORM-FROM-STRING "#.(+ 1 1)"))) 473 | 2) 474 | (DEFTEST (READ-RADIX 1) 475 | (LET ((MARKER (READ-FORM-FROM-STRING "#B1011"))) 476 | (VALUES (RADIX-MARKER-BASE MARKER) (MARKER-VALUE MARKER))) 477 | 2 11) 478 | (DEFTEST (READ-RADIX 2) 479 | (LET ((MARKER (READ-FORM-FROM-STRING "#14R11"))) 480 | (VALUES (RADIX-MARKER-BASE MARKER) (MARKER-VALUE MARKER))) 481 | 14 15) 482 | (DEFTEST READ-COMPLEX 483 | (LET ((MARKER (READ-FORM-FROM-STRING "#C(0 1)"))) 484 | (MARKER-VALUE MARKER)) 485 | #C(0 1)) 486 | (DEFTEST READ-ARRAY 487 | (VALUES (MARKER-VALUE (READ-FORM-FROM-STRING "#2A((1 2 3) (4 5 6))")) 488 | (MARKER-VALUE (READ-FORM-FROM-STRING "#2A()"))) 489 | #2A((1 2 3) (4 5 6)) #2A()) 490 | (DEFSTRUCT PERSON (NAME 7 :TYPE STRING)) 491 | (DEFTEST STRUCTURE-MARKER 492 | (PERSON-NAME 493 | (MARKER-VALUE (READ-FORM-FROM-STRING "#S(person :name \"James\")"))) 494 | "James") 495 | (DEFTEST FEATUREP 496 | (LET ((*FEATURES* '(:A :B))) 497 | (FEATUREP '(:AND :A (:OR :C :B) (:NOT :D)))) 498 | T) 499 | (DEFTEST (READ-TIME-CONDITIONAL 1) 500 | (LET* ((*EVALUATING* NIL) 501 | (*FEATURES* NIL) 502 | (CONDITIONAL (MARKER-VALUE (READ-FORM-FROM-STRING "#-foo 1")))) 503 | (VALUES (READ-TIME-CONDITIONAL-PLUSP CONDITIONAL) 504 | (READ-TIME-CONDITIONAL-TEST CONDITIONAL) 505 | (READ-TIME-CONDITIONAL-FORM CONDITIONAL))) 506 | NIL :FOO " 1") 507 | (DEFTEST (READ-TIME-CONDITIONAL 2) 508 | (LET ((*FEATURES* '(:A)) (*EVALUATING* T)) 509 | (VALUES (MARKER-VALUE (READ-FORM-FROM-STRING "#+a 1")) 510 | (MARKER-VALUE (READ-FORM-FROM-STRING "#-b 2")) 511 | (MARKER-BOUNDP (READ-FORM-FROM-STRING "#-a 1")) 512 | (MARKER-BOUNDP (READ-FORM-FROM-STRING "#+b 2")))) 513 | 1 2 NIL NIL) 514 | (DEFTEST (READ-TIME-CONDITIONAL CHARPOS) 515 | (LIST-MARKER-CHARPOS 516 | (WITH-MODE :LISP 517 | (READ-FROM-STRING-WITH-CHARPOS (FORMAT NIL "(#-:foo foo~% bar)")))) 518 | (1 0 1)) 519 | (DEFTEST READ-BLOCK-COMMENT 520 | (WITH-INPUT-FROM-STRING (S "#|foo|#") 521 | (WITH-MODE :LISP 522 | (READ-MAYBE-NOTHING S))) 523 | NIL) 524 | (DEFTEST SNARF-UNTIL-CONTROL-CHAR 525 | (WITH-INPUT-FROM-STRING (S "abc*123") 526 | (VALUES (SNARF-UNTIL-CONTROL-CHAR S #\*) 527 | (SNARF-UNTIL-CONTROL-CHAR S '(#\a #\3)))) 528 | "abc" "*12") 529 | (DEFTEST READ-INNER-LISP 530 | (WITH-MODE :TEX 531 | (VALUES (READ-FROM-STRING "|:foo :bar|"))) 532 | (:FOO :BAR)) 533 | (DEFTEST LITERAL-@ 534 | (WITH-MODE :TEX 535 | (VALUES (READ-FROM-STRING "@@"))) 536 | "@") 537 | (DEFTEST @Q-LISP 538 | (WITH-MODE :LISP 539 | (VALUES (READ-FROM-STRING (FORMAT NIL "@q nil~%t")))) 540 | T) 541 | (DEFTEST START-TEST-SECTION-READER 542 | (LET ((*TEST-SECTIONS* (MAKE-ARRAY 2 :FILL-POINTER 0))) 543 | (WITH-INPUT-FROM-STRING (S (FORMAT NIL "@t~%:foo @t* :bar")) 544 | (WITH-MODE :LISP 545 | (VALUES (TYPEP (READ S) 'TEST-SECTION) (READ S) 546 | (TYPEP (READ S) 'STARRED-TEST-SECTION) (READ S))))) 547 | T :FOO T :BAR) 548 | (DEFTEST START-CODE-MARKER 549 | (WITH-MODE :TEX 550 | (VALUES-LIST 551 | (MAPCAR (LAMBDA (MARKER) (TYPEP MARKER 'START-CODE-MARKER)) 552 | (LIST (READ-FROM-STRING "@l") (READ-FROM-STRING "@p"))))) 553 | T T) 554 | (DEFTEST (READ-EVALUATED-FORM 1) 555 | (LET ((MARKER (READ-FORM-FROM-STRING (FORMAT NIL "@e t")))) 556 | (AND (TYPEP MARKER 'EVALUATED-FORM-MARKER) (MARKER-VALUE MARKER))) 557 | T) 558 | (DEFTEST (READ-EVALUATED-FORM 2) 559 | (LET ((MARKER (READ-FORM-FROM-STRING (FORMAT NIL "@e~%t")))) 560 | (AND (TYPEP MARKER 'EVALUATED-FORM-MARKER) (MARKER-VALUE MARKER))) 561 | T) 562 | (DEFTEST READ-CONTROL-TEXT 563 | (WITH-INPUT-FROM-STRING (S "frob |foo| and tweak |bar|@>") 564 | (READ-CONTROL-TEXT S)) 565 | "frob |foo| and tweak |bar|") 566 | (DEFTEST (READ-SECTION-NAME :TEX) 567 | (WITH-MODE :TEX 568 | (SECTION-NAME (READ-FROM-STRING "@="))) 569 | "foo") 570 | (DEFTEST (READ-SECTION-NAME :LISP) 571 | (WITH-SAMPLE-NAMED-SECTIONS 572 | (WITH-MODE :LISP 573 | (SECTION-NAME (READ-FROM-STRING "@")))) 574 | "foo") 575 | (DEFTEST SECTION-NAME-DEFINITION-ERROR 576 | (WITH-SAMPLE-NAMED-SECTIONS 577 | (SECTION-NAME 578 | (HANDLER-BIND ((SECTION-NAME-DEFINITION-ERROR 579 | (LAMBDA (CONDITION) 580 | (DECLARE (IGNORE CONDITION)) 581 | (INVOKE-RESTART 'USE-SECTION)))) 582 | (WITH-MODE :LISP 583 | (READ-FROM-STRING "@="))))) 584 | "foo") 585 | (DEFTEST SECTION-NAME-USE-ERROR 586 | (WITH-SAMPLE-NAMED-SECTIONS 587 | (SECTION-NAME 588 | (HANDLER-BIND ((SECTION-NAME-USE-ERROR 589 | (LAMBDA (CONDITION) 590 | (DECLARE (IGNORE CONDITION)) 591 | (INVOKE-RESTART 'CITE-SECTION)))) 592 | (WITH-MODE :TEX 593 | (READ-FROM-STRING "@"))))) 594 | "foo") 595 | (DEFTEST INDEX-PACKAGE-READER 596 | (LET ((*INDEX-PACKAGES* NIL)) 597 | (READ-FORM-FROM-STRING "@x\"CLWEB\"") 598 | (NOT (NULL (INTERESTING-SYMBOL-P 'INDEX-PACKAGE-READER)))) 599 | T) 600 | (DEFTEST (TANGLE-1 1) (TANGLE-1 (READ-FORM-FROM-STRING ":a")) :A NIL) 601 | (DEFTEST (TANGLE-1 2) (TANGLE-1 (READ-FORM-FROM-STRING "(:a :b :c)")) 602 | (:A :B :C) T) 603 | (DEFTEST (TANGLE-1 3) 604 | (WITH-SAMPLE-NAMED-SECTIONS (TANGLE-1 (READ-FORM-FROM-STRING "@"))) 605 | (:FOO) T) 606 | (DEFTEST TANGLE 607 | (WITH-SAMPLE-NAMED-SECTIONS 608 | (TANGLE (READ-FORM-FROM-STRING (FORMAT NIL "(:a @~% :b)")))) 609 | (:A :FOO :B) T) 610 | (DEFTEST PRINT-ESCAPED 611 | (WITH-OUTPUT-TO-STRING (S) (PRINT-ESCAPED S "foo#{bar}*baz")) 612 | "foo\\#$\\{$bar$\\}$*baz") 613 | (DEFMETHOD PRINT-OBJECT ((X NAMESPACE) STREAM) 614 | (PRINT-UNREADABLE-OBJECT (X STREAM :TYPE T :IDENTITY T) 615 | (WHEN (LOCAL-BINDING-P X) (PRIN1 :LOCAL STREAM)))) 616 | (DEFTEST (UPDATE-CONTEXT GENERIC-SETF) 617 | (TYPEP (UPDATE-CONTEXT '(SETF CLASS-NAME) (MAKE-CONTEXT 'OPERATOR) NIL) 618 | 'GENERIC-SETF-FUNCTION-NAME) 619 | T) 620 | (DEFTEST (UPDATE-CONTEXT MACRO) 621 | (LET ((CONTEXT (UPDATE-CONTEXT 'SETF (MAKE-CONTEXT 'OPERATOR) NIL))) 622 | (AND (TYPEP CONTEXT 'MACRO-NAME) (NOT (LOCAL-BINDING-P CONTEXT)))) 623 | T) 624 | (DEFTEST (UPDATE-CONTEXT LOCAL-MACRO) 625 | (LET ((CONTEXT 626 | (UPDATE-CONTEXT 'FOO (MAKE-CONTEXT 'OPERATOR) 627 | (AUGMENT-ENVIRONMENT 628 | (ENSURE-PORTABLE-WALKING-ENVIRONMENT NIL) :MACRO 629 | `((FOO 630 | ,(LAMBDA (FORM ENV) 631 | (DECLARE (IGNORE ENV)) 632 | FORM))))))) 633 | (AND (TYPEP CONTEXT 'MACRO-NAME) (LOCAL-BINDING-P CONTEXT))) 634 | T) 635 | (DEFTEST (UPDATE-CONTEXT FUNCTION) 636 | (LET ((CONTEXT (UPDATE-CONTEXT 'IDENTITY (MAKE-CONTEXT 'OPERATOR) NIL))) 637 | (AND (TYPEP CONTEXT 'FUNCTION-NAME) (NOT (LOCAL-BINDING-P CONTEXT)))) 638 | T) 639 | (DEFTEST (UPDATE-CONTEXT LOCAL-FUNCTION) 640 | (LET ((CONTEXT 641 | (UPDATE-CONTEXT 'FOO (MAKE-CONTEXT 'OPERATOR) 642 | (AUGMENT-ENVIRONMENT 643 | (ENSURE-PORTABLE-WALKING-ENVIRONMENT NIL) :FUNCTION 644 | '(FOO))))) 645 | (AND (TYPEP CONTEXT 'FUNCTION-NAME) (LOCAL-BINDING-P CONTEXT))) 646 | T) 647 | (DEFTEST (UPDATE-CONTEXT SPECIAL-OPERATOR) 648 | (LET ((CONTEXT (UPDATE-CONTEXT 'IF (MAKE-CONTEXT 'OPERATOR) NIL))) 649 | (AND (TYPEP CONTEXT 'SPECIAL-OPERATOR) (NOT (LOCAL-BINDING-P CONTEXT)))) 650 | T) 651 | (DEFTEST WALK-ATOMIC-FORM 652 | (WALK-ATOMIC-FORM (MAKE-INSTANCE 'WALKER) ':FOO NIL NIL) :FOO) 653 | (DEFTEST WALK-NON-ATOMIC-FORM 654 | (HANDLER-CASE (WALK-ATOMIC-FORM (MAKE-INSTANCE 'WALKER) '(A B C) NIL NIL) 655 | (ERROR NIL NIL)) 656 | NIL) 657 | (DEFTEST WALK-COMPOUND-FORM 658 | (WALK-COMPOUND-FORM (MAKE-INSTANCE 'WALKER) :FOO '(:FOO 2 3) NIL) (:FOO 2 3)) 659 | (DEFTEST (WALK-COMPOUND-FORM LAMBDA) 660 | (LET ((OPERATOR '(LAMBDA (X) X))) 661 | (WALK-COMPOUND-FORM (MAKE-INSTANCE 'WALKER) OPERATOR `(,OPERATOR 0) 662 | (ENSURE-PORTABLE-WALKING-ENVIRONMENT NIL))) 663 | ((LAMBDA (X) X) 0)) 664 | (DEFTEST (WALK-COMPOUND-FORM INVALID) 665 | (HANDLER-CASE 666 | (LET ((OPERATOR '(X))) 667 | (WALK-COMPOUND-FORM (MAKE-INSTANCE 'WALKER) OPERATOR `(,OPERATOR 0) 668 | (ENSURE-PORTABLE-WALKING-ENVIRONMENT NIL))) 669 | (ERROR NIL NIL)) 670 | NIL) 671 | (DEFTEST LAMBDA-EXPRESSION-TYPE 672 | (FLET ((LAMBDA-EXPRESSION-P (X) 673 | (TYPEP X 'LAMBDA-EXPRESSION))) 674 | (AND (LAMBDA-EXPRESSION-P '(LAMBDA (X) X)) 675 | (LAMBDA-EXPRESSION-P '(LAMBDA () T)) (LAMBDA-EXPRESSION-P '(LAMBDA ())) 676 | (NOT (LAMBDA-EXPRESSION-P '(LAMBDA X X))) 677 | (NOT (LAMBDA-EXPRESSION-P 'LAMBDA)))) 678 | T) 679 | (DEFCLASS TEST-WALKER (WALKER) NIL) 680 | (DEFINE-SPECIAL-FORM-WALKER ENSURE-TOPLEVEL 681 | ((WALKER TEST-WALKER) FORM ENV &KEY TOPLEVEL) 682 | (DESTRUCTURING-BIND 683 | (OPERATOR &OPTIONAL (ENSURE-TOPLEVEL T)) 684 | FORM 685 | (DECLARE (IGNORE OPERATOR)) 686 | (ASSERT 687 | (IF ENSURE-TOPLEVEL 688 | TOPLEVEL 689 | (NOT TOPLEVEL)) 690 | (FORM ENSURE-TOPLEVEL TOPLEVEL) "~:[At~;Not at~] top level." 691 | ENSURE-TOPLEVEL)) 692 | FORM) 693 | (DEFTEST TOPLEVEL 694 | (LET ((WALKER (MAKE-INSTANCE 'TEST-WALKER)) 695 | (ENV (ENSURE-PORTABLE-WALKING-ENVIRONMENT NIL))) 696 | (FLET ((WALK (FORM TOPLEVEL) 697 | (TREE-EQUAL (WALK-FORM WALKER FORM ENV TOPLEVEL) FORM))) 698 | (VALUES (WALK '(ENSURE-TOPLEVEL) T) (WALK '(ENSURE-TOPLEVEL NIL) NIL) 699 | (WALK 700 | '(LET () 701 | (ENSURE-TOPLEVEL NIL)) 702 | T) 703 | (HANDLER-CASE (WALK '(ENSURE-TOPLEVEL) NIL) (ERROR NIL NIL)) 704 | (HANDLER-CASE (WALK '(ENSURE-TOPLEVEL NIL) T) (ERROR NIL NIL)) 705 | (HANDLER-CASE 706 | (WALK 707 | '(LET () 708 | (ENSURE-TOPLEVEL)) 709 | T) 710 | (ERROR NIL NIL))))) 711 | T T T NIL NIL NIL) 712 | (DEFMACRO DEFINE-WALKER-TEST 713 | (NAME-AND-OPTIONS FORM &OPTIONAL (RESULT NIL RESULT-SUPPLIED)) 714 | (DESTRUCTURING-BIND 715 | (NAME &KEY (TOPLEVEL NIL)) 716 | (ENSURE-LIST NAME-AND-OPTIONS) 717 | `(DEFTEST (WALK ,NAME) 718 | (LET* ((FORM ',FORM) 719 | (WALKER (MAKE-INSTANCE 'TEST-WALKER)) 720 | (WALKED-FORM (WALK-FORM WALKER FORM NIL ,TOPLEVEL))) 721 | ,(COND (RESULT `(TREE-EQUAL WALKED-FORM ',RESULT)) 722 | ((NOT RESULT-SUPPLIED) '(TREE-EQUAL WALKED-FORM FORM)) (T T))) 723 | T))) 724 | (DEFINE-WALKER-TEST PROGN (PROGN :FOO :BAR :BAZ)) 725 | (DEFINE-WALKER-TEST (PROGN-TOPLEVEL :TOPLEVEL T) (PROGN (ENSURE-TOPLEVEL))) 726 | (DEFINE-WALKER-TEST BLOCK/RETURN-FROM (BLOCK :FOO (RETURN-FROM :FOO 4))) 727 | (DEFINE-WALKER-TEST TAGBODY/GO (TAGBODY FOO (GO FOO))) 728 | (DEFINE-WALKER-TEST CATCH/THROW (CATCH 'FOO (THROW 'FOO :FOO))) 729 | (DEFINE-WALKER-TEST THE (THE (OR NUMBER NIL) (SQRT 4))) 730 | (DEFINE-WALKER-TEST QUOTE-1 'FOO) 731 | (DEFINE-WALKER-TEST QUOTE-2 '(1 2 3)) 732 | (DEFINE-WALKER-TEST (EVAL-WHEN-NON-TOPLEVEL :TOPLEVEL NIL) 733 | (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) 734 | (ERROR "Oops; this shouldn't have been evaluated."))) 735 | (DEFTEST (WALK EVAL-WHEN-TOPLEVEL) 736 | (LET* ((STRING-OUTPUT-STREAM (MAKE-STRING-OUTPUT-STREAM)) 737 | (*STANDARD-OUTPUT* STRING-OUTPUT-STREAM) 738 | (WALKER (MAKE-INSTANCE 'TEST-WALKER)) 739 | (FORM '(EVAL-WHEN (:COMPILE-TOPLEVEL) (PRINC :FOO)))) 740 | (AND (TREE-EQUAL (WALK-FORM WALKER FORM NIL T) FORM) 741 | (GET-OUTPUT-STREAM-STRING STRING-OUTPUT-STREAM))) 742 | "FOO") 743 | (DEFTEST (WALK DEFCONSTANT) 744 | (LET ((NAME (MAKE-SYMBOL "TWO-PI")) (WALKER (MAKE-INSTANCE 'WALKER))) 745 | (AND (WALK-FORM WALKER `(DEFCONSTANT ,NAME (* 2 PI)) NIL T) 746 | (SYMBOL-VALUE NAME))) 747 | #.(* 2 PI)) 748 | (DEFINE-WALKER-TEST FUNCTION #'FOO) 749 | (DEFINE-WALKER-TEST FUNCTION-SETF-FUNCTION #'(SETF FOO)) 750 | (DEFINE-WALKER-TEST FUNCTION-LAMBDA #'(LAMBDA (X) X)) 751 | (DEFTEST (PARSE-BODY 1) 752 | (PARSE-BODY '("doc" (DECLARE (OPTIMIZE SPEED)) :FOO :BAR) :DOC-STRING-ALLOWED 753 | T) 754 | (:FOO :BAR) ((OPTIMIZE SPEED)) "doc") 755 | (DEFTEST (PARSE-BODY 2) 756 | (PARSE-BODY 757 | '((DECLARE (OPTIMIZE SPEED)) "doc" (DECLARE (OPTIMIZE SPACE)) :FOO :BAR) 758 | :DOC-STRING-ALLOWED T) 759 | (:FOO :BAR) ((OPTIMIZE SPEED) (OPTIMIZE SPACE)) "doc") 760 | (DEFTEST (PARSE-BODY 3) (PARSE-BODY '("doc" "string") :DOC-STRING-ALLOWED T) 761 | ("string") NIL "doc") 762 | (DEFTEST (PARSE-BODY 4) 763 | (PARSE-BODY '((DECLARE (OPTIMIZE DEBUG)) "string") :DOC-STRING-ALLOWED T) 764 | ("string") ((OPTIMIZE DEBUG)) NIL) 765 | (DEFTEST (PARSE-BODY 5) 766 | (PARSE-BODY '((DECLARE (OPTIMIZE DEBUG)) "string") :DOC-STRING-ALLOWED NIL) 767 | ("string") ((OPTIMIZE DEBUG)) NIL) 768 | (DEFTEST WALK-DECLARATION-SPECIFIERS 769 | (EQUAL 770 | (WALK-DECLARATION-SPECIFIERS (MAKE-INSTANCE 'WALKER) 771 | '((TYPE FOO X) (SPECIAL X Y) (IGNORE Z) 772 | (IGNORABLE #'F) 773 | (OPTIMIZE (SPEED 3) (SAFETY 0))) 774 | NIL) 775 | '((SPECIAL X Y) (IGNORE Z) (IGNORABLE #'F) (OPTIMIZE (SPEED 3) (SAFETY 0)))) 776 | T) 777 | (DEFVAR *FOO* NIL "A global special variable.") 778 | (DEFTEST WALK-BINDINGS 779 | (LET ((NAMES '(*FOO* BAR BAZ)) 780 | (WALKER (MAKE-INSTANCE 'WALKER)) 781 | (CONTEXT (MAKE-CONTEXT 'VARIABLE-NAME)) 782 | (ENV (ENSURE-PORTABLE-WALKING-ENVIRONMENT NIL))) 783 | (MULTIPLE-VALUE-BIND (WALKED-NAMES NEW-ENV) 784 | (WALK-BINDINGS WALKER NAMES CONTEXT ENV :DECLARE '((SPECIAL BAR))) 785 | (AND (EQUAL WALKED-NAMES NAMES) 786 | (EQUAL 787 | (MAPCAR (LAMBDA (VAR) (VARIABLE-INFORMATION VAR NEW-ENV)) NAMES) 788 | '(:SPECIAL :SPECIAL :LEXICAL))))) 789 | T) 790 | (DEFINE-SPECIAL-FORM-WALKER CHECK-BINDING 791 | ((WALKER TEST-WALKER) FORM ENV &KEY TOPLEVEL) 792 | (DECLARE (IGNORE TOPLEVEL)) 793 | (FLET ((CHECK-BINDING 794 | (NAME NAMESPACE EXPECTED-TYPE LOCAL &AUX (ENV (AND LOCAL ENV))) 795 | (LET ((ACTUAL-TYPE 796 | (ECASE NAMESPACE 797 | (:FUNCTION (FUNCTION-INFORMATION NAME ENV)) 798 | (:VARIABLE (VARIABLE-INFORMATION NAME ENV))))) 799 | (ASSERT (EQL ACTUAL-TYPE EXPECTED-TYPE) (NAME NAMESPACE LOCAL) 800 | "~:[Global~;Local~] ~(~A~) binding of ~S type ~S, not ~S." 801 | LOCAL NAMESPACE NAME ACTUAL-TYPE EXPECTED-TYPE)))) 802 | (DESTRUCTURING-BIND 803 | (SYMBOLS NAMESPACE TYPE &OPTIONAL (LOCAL T)) 804 | (CDR FORM) 805 | (LOOP WITH SYMBOLS = (ENSURE-LIST SYMBOLS) 806 | FOR SYMBOL IN SYMBOLS 807 | DO (CHECK-BINDING SYMBOL NAMESPACE TYPE LOCAL)) 808 | FORM))) 809 | (DEFINE-WALKER-TEST ORDINARY-LAMBDA-LIST 810 | (LAMBDA 811 | (X Y 812 | &OPTIONAL 813 | (O 814 | (+ (CHECK-BINDING O :VARIABLE NIL) (CHECK-BINDING X :VARIABLE :SPECIAL) 815 | (CHECK-BINDING Y :VARIABLE :LEXICAL))) 816 | (P NIL P-SUPPLIED-P) 817 | &REST ARGS 818 | &KEY ((SECRET K) 1 K-S-P) (K2 (CHECK-BINDING K-S-P :VARIABLE :LEXICAL)) 819 | K3 &ALLOW-OTHER-KEYS 820 | &AUX W 821 | (Z 822 | (IF K-S-P 823 | O 824 | X))) 825 | (DECLARE (SPECIAL X)) 826 | (CHECK-BINDING X :VARIABLE :SPECIAL) 827 | (CHECK-BINDING (Y Z O K K-S-P K2 K3 ARGS W Z) :VARIABLE :LEXICAL) 828 | (CHECK-BINDING SECRET :VARIABLE NIL))) 829 | (DEFINE-WALKER-TEST MACRO-LAMBDA-LIST 830 | (LAMBDA 831 | (&WHOLE W (X Y) 832 | &OPTIONAL ((O) (+ X Y)) 833 | &KEY ((:K (K1 K2)) (2 3) K-S-P) &ENVIRONMENT ENV . BODY) 834 | (CHECK-BINDING (W X Y O K1 K2 K-S-P ENV BODY) :VARIABLE :LEXICAL))) 835 | (DEFINE-WALKER-TEST LET 836 | (LET ((X 1) (Y (CHECK-BINDING X :VARIABLE NIL))) 837 | (DECLARE (SPECIAL X)) 838 | (CHECK-BINDING X :VARIABLE :SPECIAL) 839 | (CHECK-BINDING Y :VARIABLE :LEXICAL))) 840 | (DEFINE-WALKER-TEST FLET 841 | (FLET ((FOO (X) 842 | (CHECK-BINDING X :VARIABLE :LEXICAL)) 843 | (BAR (Y) 844 | Y)) 845 | (DECLARE (SPECIAL X) 846 | (IGNORE (FUNCTION BAR))) 847 | (CHECK-BINDING X :VARIABLE :SPECIAL) 848 | (CHECK-BINDING FOO :FUNCTION :FUNCTION))) 849 | (DEFINE-WALKER-TEST 850 | (MACROLET :TOPLEVEL 851 | T) 852 | (MACROLET ((FOO (X) 853 | (CHECK-BINDING X :VARIABLE :LEXICAL))) 854 | (CHECK-BINDING FOO :FUNCTION :MACRO) 855 | (ENSURE-TOPLEVEL))) 856 | (DEFINE-WALKER-TEST 857 | (SYMBOL-MACROLET :TOPLEVEL 858 | T) 859 | (SYMBOL-MACROLET ((FOO :FOO) (BAR :BAR)) 860 | (CHECK-BINDING (FOO BAR) :VARIABLE :SYMBOL-MACRO) 861 | (ENSURE-TOPLEVEL) 862 | FOO 863 | BAR) 864 | (SYMBOL-MACROLET ((FOO :FOO) (BAR :BAR)) 865 | (CHECK-BINDING (FOO BAR) :VARIABLE :SYMBOL-MACRO) 866 | (ENSURE-TOPLEVEL) 867 | :FOO 868 | :BAR)) 869 | (DEFINE-WALKER-TEST LET* 870 | (LET* ((X 1) (Y (CHECK-BINDING X :VARIABLE :SPECIAL))) 871 | (DECLARE (SPECIAL X)) 872 | (CHECK-BINDING Y :VARIABLE :LEXICAL))) 873 | (DEFINE-WALKER-TEST LABELS 874 | (LABELS ((FOO (X) 875 | (CHECK-BINDING X :VARIABLE :LEXICAL)) 876 | (BAR (Y) 877 | (CHECK-BINDING FOO :FUNCTION :FUNCTION))) 878 | (DECLARE (SPECIAL X)) 879 | (CHECK-BINDING X :VARIABLE :SPECIAL) 880 | (CHECK-BINDING FOO :FUNCTION :FUNCTION))) 881 | (DEFINE-WALKER-TEST (LOCALLY :TOPLEVEL T) 882 | (LOCALLY 883 | NIL 884 | (ENSURE-TOPLEVEL) 885 | (LET ((Y T)) 886 | (CHECK-BINDING Y :VARIABLE :LEXICAL) 887 | (LOCALLY 888 | (DECLARE (SPECIAL Y)) 889 | (ENSURE-TOPLEVEL NIL) 890 | (CHECK-BINDING Y :VARIABLE :SPECIAL))))) 891 | (DEFINE-WALKER-TEST 892 | (DECLAIM :TOPLEVEL 893 | T) 894 | (PROGN (DECLAIM (SPECIAL *FOO*)) (CHECK-BINDING *FOO* :VARIABLE :SPECIAL NIL))) 895 | (DEFTEST (WALK DEFINE-SYMBOL-MACRO) 896 | (LET ((WALKER (MAKE-INSTANCE 'TEST-WALKER)) (NAME (GENSYM))) 897 | (EVAL `(DEFINE-SYMBOL-MACRO ,NAME (ENSURE-TOPLEVEL))) 898 | (NOT 899 | (NULL 900 | (WALK-FORM WALKER `(CHECK-BINDING ,NAME :VARIABLE :SYMBOL-MACRO NIL) NIL 901 | T)))) 902 | T) 903 | (DEFCLASS TRACING-WALKER (WALKER) NIL) 904 | (DEFMETHOD WALK-ATOMIC-FORM :BEFORE 905 | ((WALKER TRACING-WALKER) FORM CONTEXT ENV &KEY TOPLEVEL) 906 | (DECLARE (IGNORE ENV)) 907 | (FORMAT *TRACE-OUTPUT* 908 | "~&~@<; ~@;walking~:[~; toplevel~] atomic form ~S ~S~:>~%" TOPLEVEL 909 | FORM CONTEXT)) 910 | (DEFMETHOD WALK-COMPOUND-FORM :BEFORE 911 | ((WALKER TRACING-WALKER) OPERATOR FORM ENV &KEY TOPLEVEL) 912 | (DECLARE (IGNORE OPERATOR ENV)) 913 | (FORMAT *TRACE-OUTPUT* 914 | "~&~@<; ~@;walking~:[~; toplevel~] compound form ~W~:>~%" TOPLEVEL 915 | FORM)) 916 | (DEFMETHOD WALK-NAME :BEFORE 917 | ((WALKER TRACING-WALKER) NAME CONTEXT ENV &REST ARGS) 918 | (DECLARE (IGNORE ENV)) 919 | (FORMAT *TRACE-OUTPUT* "~&~@<; ~@;walking name ~S ~S~@[~S~]~:>~%" NAME 920 | CONTEXT ARGS)) 921 | (DEFMETHOD WALK-BINDINGS :BEFORE 922 | ((WALKER TRACING-WALKER) NAMES CONTEXT ENV &KEY DECLARE) 923 | (DECLARE (IGNORE ENV DECLARE)) 924 | (FORMAT *TRACE-OUTPUT* "~&~@<; ~@;walking bindings ~S ~S~:>~%" NAMES CONTEXT)) 925 | (DEFTEST INDEX-PACKAGE 926 | (LET ((*INDEX-PACKAGES* NIL)) 927 | (INDEX-PACKAGE "KEYWORD") 928 | (VALUES (INTERESTING-SYMBOL-P 'NIL) 929 | (NOT (NULL (INTERESTING-SYMBOL-P ':FOO))))) 930 | NIL T) 931 | (INDEX-PACKAGE "CLWEB") 932 | (DEFTEST HEADING-NAME (HEADING-NAME (MAKE-HEADING "foo" (MAKE-HEADING "bar"))) 933 | "foo bar") 934 | (DEFTEST (HEADING-NAME CHARACTER) (HEADING-NAME #\A) "A") 935 | (DEFTEST (HEADING-NAME STRING) (HEADING-NAME "\\foo") "foo") 936 | (DEFTEST (HEADING-NAME SYMBOL) 937 | (VALUES (HEADING-NAME :FOO) (HEADING-NAME '|\\foo|)) "FOO" "\\foo") 938 | (DEFUN ENTRY-HEADING-STRICTLY-LESSP (X Y) 939 | (AND (ENTRY-HEADING-LESSP X Y) (NOT (ENTRY-HEADING-LESSP Y X)))) 940 | (DEFTEST ENTRY-HEADING-LESSP 941 | (LET* ((A (MAKE-HEADING "a")) 942 | (B (MAKE-HEADING "b")) 943 | (X (MAKE-HEADING "x")) 944 | (Y (MAKE-HEADING "y")) 945 | (AX (MAKE-HEADING "a" X)) 946 | (AY (MAKE-HEADING "a" Y)) 947 | (BX (MAKE-HEADING "b" X)) 948 | (BY (MAKE-HEADING "a" Y))) 949 | (EVERY #'IDENTITY 950 | (LIST (NOT (ENTRY-HEADING-STRICTLY-LESSP A A)) 951 | (ENTRY-HEADING-STRICTLY-LESSP A B) 952 | (ENTRY-HEADING-STRICTLY-LESSP A AX) 953 | (ENTRY-HEADING-STRICTLY-LESSP AX AY) 954 | (ENTRY-HEADING-STRICTLY-LESSP AX BX) 955 | (ENTRY-HEADING-STRICTLY-LESSP AY BX) 956 | (ENTRY-HEADING-STRICTLY-LESSP AX BY)))) 957 | T) 958 | (DEFUN ENTRY-HEADING-SYMMETRIC-EQUALP (X Y) 959 | (AND (ENTRY-HEADING-EQUALP X Y) (ENTRY-HEADING-EQUALP Y X))) 960 | (DEFUN ENTRY-HEADING-SYMMETRIC-UNEQUALP (X Y) 961 | (AND (NOT (ENTRY-HEADING-EQUALP X Y)) (NOT (ENTRY-HEADING-EQUALP Y X)))) 962 | (DEFTEST ENTRY-HEADING-EQUALP 963 | (LET* ((A (MAKE-HEADING "a")) 964 | (B (MAKE-HEADING "b")) 965 | (X (MAKE-HEADING "x")) 966 | (Y (MAKE-HEADING "y")) 967 | (AX (MAKE-HEADING "a" X)) 968 | (AY (MAKE-HEADING "a" Y))) 969 | (EVERY #'IDENTITY 970 | (LIST (ENTRY-HEADING-SYMMETRIC-EQUALP A A) 971 | (ENTRY-HEADING-SYMMETRIC-UNEQUALP A B) 972 | (ENTRY-HEADING-SYMMETRIC-EQUALP AX AX) 973 | (ENTRY-HEADING-SYMMETRIC-UNEQUALP AX AY)))) 974 | T) 975 | (DEFMETHOD PRINT-OBJECT ((HEADING HEADING) STREAM) 976 | (PRINT-UNREADABLE-OBJECT (HEADING STREAM :TYPE T :IDENTITY NIL) 977 | (FORMAT STREAM "\"~A\"" (HEADING-NAME HEADING)))) 978 | (DEFTEST JOIN-STRINGS 979 | (VALUES (JOIN-STRINGS "foo") (JOIN-STRINGS '("foo" "bar")) 980 | (JOIN-STRINGS '(:FOO :BAR NIL :BAZ) #\,)) 981 | "foo" "foo bar" "FOO,BAR,BAZ") 982 | (DEFCLASS DEAD-BEEF NIL NIL) 983 | (DEFCLASS KOBE-BEEF (DEAD-BEEF) NIL) 984 | (DEFCLASS ROTTEN-BEEF (DEAD-BEEF) NIL) 985 | (DEFGENERIC DESCRIBE-BEEF 986 | (BEEF) 987 | (:METHOD-COMBINATION JOIN-STRINGS ", ") 988 | (:METHOD ((BEEF DEAD-BEEF)) "steak") 989 | (:METHOD :PREFIX ((BEEF DEAD-BEEF)) (LIST "big" "fat" "juicy")) 990 | (:METHOD :SUFFIX ((BEEF DEAD-BEEF)) "yum!") 991 | (:METHOD :PREFIX ((BEEF KOBE-BEEF)) "delicious") 992 | (:METHOD ((BEEF KOBE-BEEF)) "Kobe") 993 | (:METHOD :SUFFIX ((BEEF KOBE-BEEF)) "from Japan") 994 | (:METHOD :OVERRIDE ((BEEF ROTTEN-BEEF)) "Yuck!")) 995 | (DEFTEST JOIN-STRINGS-METHOD-COMBINATION 996 | (VALUES (DESCRIBE-BEEF (MAKE-INSTANCE 'DEAD-BEEF)) 997 | (DESCRIBE-BEEF (MAKE-INSTANCE 'KOBE-BEEF)) 998 | (DESCRIBE-BEEF (MAKE-INSTANCE 'ROTTEN-BEEF))) 999 | "big, fat, juicy, steak, yum!" 1000 | "delicious, big, fat, juicy, Kobe, steak, yum!, from Japan" "Yuck!") 1001 | (DEFTEST FUNCTION-HEADING-NAME 1002 | (VALUES (HEADING-NAME (MAKE-CONTEXT 'FUNCTION-NAME)) 1003 | (HEADING-NAME (MAKE-CONTEXT 'FUNCTION-NAME :LOCAL T)) 1004 | (HEADING-NAME (MAKE-CONTEXT 'GENERIC-FUNCTION-NAME)) 1005 | (HEADING-NAME (MAKE-CONTEXT 'SETF-FUNCTION-NAME)) 1006 | (HEADING-NAME (MAKE-CONTEXT 'SETF-FUNCTION-NAME :LOCAL T))) 1007 | "function" "local function" "generic function" "setf function" 1008 | "local setf function") 1009 | (DEFTEST METHOD-HEADING-NAME 1010 | (VALUES (HEADING-NAME (MAKE-CONTEXT 'METHOD-NAME)) 1011 | (HEADING-NAME 1012 | (MAKE-CONTEXT 'METHOD-NAME :QUALIFIERS '(:BEFORE :DURING :AFTER)))) 1013 | "primary method" "before during after method") 1014 | (DEFMETHOD PRINT-OBJECT ((ENTRY INDEX-ENTRY) STREAM) 1015 | (PRINT-UNREADABLE-OBJECT (ENTRY STREAM :TYPE T :IDENTITY NIL) 1016 | (FORMAT STREAM "~W:" (ENTRY-HEADING ENTRY)) 1017 | (DOLIST 1018 | (LOCATOR 1019 | (SORT (COPY-LIST (ENTRY-LOCATORS ENTRY)) #'< :KEY 1020 | (LAMBDA (X) (SECTION-NUMBER (LOCATION X))))) 1021 | (FORMAT STREAM " ~:[~D~;[~D]~]" (LOCATOR-DEFINITION-P LOCATOR) 1022 | (SECTION-NUMBER (LOCATION LOCATOR)))))) 1023 | (DEFTEST (ADD-INDEX-ENTRY 1) 1024 | (LET ((INDEX (MAKE-INDEX)) (HEADING 'FOO)) 1025 | (ADD-INDEX-ENTRY INDEX HEADING 1) 1026 | (ADD-INDEX-ENTRY INDEX HEADING 2) 1027 | (ADD-INDEX-ENTRY INDEX HEADING 3) 1028 | (SORT (MAPCAR #'LOCATION (FIND-INDEX-ENTRIES INDEX HEADING)) #'<)) 1029 | (1 2 3)) 1030 | (DEFTEST (ADD-INDEX-ENTRY 2) 1031 | (LET* ((INDEX (MAKE-INDEX)) (HEADING 'FOO)) 1032 | (ADD-INDEX-ENTRY INDEX HEADING 1) 1033 | (ADD-INDEX-ENTRY INDEX HEADING 1 T) 1034 | (LOCATOR-DEFINITION-P (FIRST (FIND-INDEX-ENTRIES INDEX HEADING)))) 1035 | T) 1036 | (DEFTEST (SYMBOL-PROVENANCE 1) 1037 | (LET ((*INDEX-PACKAGES* (LIST (FIND-PACKAGE "KEYWORD")))) 1038 | (SYMBOL-PROVENANCE (SUBSTITUTE-REFERRING-SYMBOLS :FOO 1))) 1039 | :FOO 1) 1040 | (DEFTEST (SYMBOL-PROVENANCE 2) (SYMBOL-PROVENANCE :FOO) :FOO) 1041 | (DEFTEST (SYMBOL-PROVENANCE 3) 1042 | (LET ((SYMBOL (MAKE-SYMBOL "FOO"))) 1043 | (EQL (SYMBOL-PROVENANCE SYMBOL) SYMBOL)) 1044 | T) 1045 | (DEFTEST (SYMBOL-PROVENANCE 4) 1046 | (LET ((*INDEX-PACKAGES* (LIST (FIND-PACKAGE "KEYWORD")))) 1047 | (SYMBOL-PROVENANCE 1048 | (MACROEXPAND 1049 | (SUBSTITUTE-REFERRING-SYMBOLS (TANGLE (READ-FORM-FROM-STRING "`,:foo")) 1050 | 1)))) 1051 | :FOO 1) 1052 | (DEFUN ALL-INDEX-ENTRIES (INDEX) 1053 | (LET ((ENTRIES)) 1054 | (MAP-BST 1055 | (LAMBDA (ENTRY) 1056 | (PUSH 1057 | (LIST (HEADING-NAME (ENTRY-HEADING ENTRY)) 1058 | (LOOP FOR LOCATOR IN (ENTRY-LOCATORS ENTRY) 1059 | IF (LOCATOR-DEFINITION-P LOCATOR) 1060 | COLLECT `(:DEF ,(SECTION-NUMBER (LOCATION LOCATOR))) ELSE 1061 | COLLECT (SECTION-NUMBER (LOCATION LOCATOR)))) 1062 | ENTRIES)) 1063 | (INDEX-ENTRIES INDEX)) 1064 | (NREVERSE ENTRIES))) 1065 | (DEFUN WALK-SECTIONS (WALKER SECTIONS ENV &KEY (VERIFY-WALK T) TOPLEVEL) 1066 | (WITH-TEMPORARY-SECTIONS SECTIONS 1067 | (LET ((TANGLED-CODE (TANGLE (UNNAMED-SECTION-CODE-PARTS *SECTIONS*))) 1068 | (MANGLED-CODE (TANGLE-CODE-FOR-INDEXING *SECTIONS*))) 1069 | (LOOP FOR FORM IN TANGLED-CODE 1070 | AND MANGLED-FORM IN MANGLED-CODE AS WALKED-FORM = (WALK-FORM WALKER 1071 | MANGLED-FORM 1072 | ENV 1073 | TOPLEVEL) 1074 | WHEN VERIFY-WALK 1075 | DO (ASSERT (TREE-EQUAL WALKED-FORM FORM) 1076 | (WALKED-FORM MANGLED-FORM FORM) 1077 | "Walked form does not match original.") 1078 | COLLECT WALKED-FORM)))) 1079 | (DEFCLASS TRACING-INDEXING-WALKER (TRACING-WALKER INDEXING-WALKER) NIL) 1080 | (DEFUN TEST-INDEXING-WALK 1081 | (SECTIONS EXPECTED-ENTRIES ENV 1082 | &KEY (VERIFY-WALK T) TOPLEVEL INDEX-LEXICALS TRACE PRINT) 1083 | (LET* ((WALKER 1084 | (MAKE-INSTANCE 1085 | (IF TRACE 1086 | 'TRACING-INDEXING-WALKER 1087 | 'INDEXING-WALKER))) 1088 | (*INDEX-LEXICAL-VARIABLES* INDEX-LEXICALS) 1089 | (WALKED-SECTIONS 1090 | (WALK-SECTIONS WALKER SECTIONS ENV :VERIFY-WALK VERIFY-WALK :TOPLEVEL 1091 | TOPLEVEL))) 1092 | (WHEN PRINT (PPRINT WALKED-SECTIONS)) 1093 | (LET ((ENTRIES (ALL-INDEX-ENTRIES (WALKER-INDEX WALKER)))) 1094 | (WHEN PRINT (PPRINT ENTRIES)) 1095 | (TREE-EQUAL ENTRIES EXPECTED-ENTRIES :TEST #'EQUAL)))) 1096 | (DEFMACRO WITH-UNIQUE-INDEXING-NAMES (NAMES &BODY BODY) 1097 | `(LET* ((TEMP-PACKAGE (MAKE-PACKAGE "INDEX-TEMP")) 1098 | (*INDEX-PACKAGES* (CONS TEMP-PACKAGE *INDEX-PACKAGES*)) 1099 | ,@(LOOP FOR NAME IN NAMES 1100 | COLLECT `(,NAME (INTERN ,(STRING NAME) TEMP-PACKAGE)))) 1101 | (UNWIND-PROTECT (PROGN ,@BODY) (DELETE-PACKAGE TEMP-PACKAGE)))) 1102 | (DEFMACRO DEFINE-INDEXING-TEST 1103 | (NAME-AND-OPTIONS SECTIONS &REST EXPECTED-ENTRIES) 1104 | (DESTRUCTURING-BIND 1105 | (NAME &REST OPTIONS &KEY AUX &ALLOW-OTHER-KEYS) 1106 | (IF (LISTP NAME-AND-OPTIONS) 1107 | (COPY-LIST NAME-AND-OPTIONS) 1108 | (LIST NAME-AND-OPTIONS)) 1109 | (REMF OPTIONS :AUX) 1110 | `(DEFTEST (INDEX ,@(ENSURE-LIST NAME)) 1111 | (WITH-UNIQUE-INDEXING-NAMES ,AUX 1112 | (TEST-INDEXING-WALK ,SECTIONS ',EXPECTED-ENTRIES NIL ,@OPTIONS)) 1113 | T))) 1114 | (DEFINE-INDEXING-TEST QUOTED-FORM 1115 | '((:SECTION :CODE ('FOO)) (:SECTION :CODE ('(FOO BAR))))) 1116 | (DEFINE-INDEXING-TEST (LEXICAL-VARIABLE :INDEX-LEXICALS T) 1117 | '((:SECTION :CODE 1118 | ((LET ((X NIL) (Y NIL) (Z NIL)) 1119 | )))) 1120 | ("X lexical variable" ((:DEF 0))) ("Y lexical variable" ((:DEF 0))) 1121 | ("Z lexical variable" ((:DEF 0)))) 1122 | (DEFINE-INDEXING-TEST SPECIAL-VARIABLE 1123 | '((:SECTION :CODE ((LOCALLY (DECLARE (SPECIAL *X*)) *X*)))) 1124 | ("*X* special variable" (0))) 1125 | (DEFINE-INDEXING-TEST 1126 | (MACROLET :VERIFY-WALK 1127 | NIL) 1128 | '((:SECTION :CODE 1129 | ((MACROLET ((FROB (X) 1130 | `(* ,X 42))) 1131 | (FROB 6))))) 1132 | ("FROB local macro" ((:DEF 0)))) 1133 | (DEFINE-INDEXING-TEST 1134 | (SYMBOL-MACROLET :VERIFY-WALK 1135 | NIL) 1136 | '((:SECTION :CODE 1137 | ((SYMBOL-MACROLET ((FOO :BAR)) 1138 | FOO)))) 1139 | ("FOO local symbol macro" ((:DEF 0)))) 1140 | (DEFINE-INDEXING-TEST CATCH/THROW 1141 | '((:SECTION :CODE ((CATCH 'FOO (THROW 'BAR (THROW (LAMBDA () 'BAZ) T)))))) 1142 | ("BAR catch tag" (0)) ("FOO catch tag" ((:DEF 0)))) 1143 | (DEFVAR *SUPER* T) 1144 | (DEFINE-SYMBOL-MACRO BAIT SWITCH) 1145 | (DEFCONSTANT THE-ULTIMATE-ANSWER 42) 1146 | (DEFINE-INDEXING-TEST (VARIABLES :VERIFY-WALK NIL) 1147 | '((:SECTION :CODE (*SUPER*)) (:SECTION :CODE (BAIT)) 1148 | (:SECTION :CODE (THE-ULTIMATE-ANSWER))) 1149 | ("*SUPER* special variable" (0)) ("BAIT symbol macro" (1)) 1150 | ("THE-ULTIMATE-ANSWER constant" (2))) 1151 | (DEFUN SQUARE (X) (* X X)) 1152 | (DEFINE-INDEXING-TEST FUNCTION '((:SECTION :CODE ((SQUARE 1)))) 1153 | ("SQUARE function" (0))) 1154 | (DEFMACRO FROB-FOO (FOO) `(1+ (* ,FOO 42))) 1155 | (DEFINE-INDEXING-TEST (MACRO :VERIFY-WALK NIL) 1156 | '((:SECTION :CODE ((FROB-FOO 6)))) ("FROB-FOO macro" (0))) 1157 | (DEFINE-INDEXING-TEST FUNCTION-NAME 1158 | '((:SECTION :CODE ((FLET ((FOO (X) X))))) 1159 | (:SECTION :CODE ((LABELS (((SETF FOO) (Y X) Y)))))) 1160 | ("FOO local function" ((:DEF 0))) ("FOO local setf function" ((:DEF 1)))) 1161 | (DEFINE-INDEXING-TEST (DEFUN :VERIFY-WALK ()) 1162 | '((:SECTION :CODE ((DEFUN FOO (X) X)))) ("FOO function" ((:DEF 0)))) 1163 | (DEFINE-INDEXING-TEST 1164 | (DEFINE-COMPILER-MACRO :VERIFY-WALK 1165 | NIL 1166 | :TOPLEVEL 1167 | T 1168 | :AUX 1169 | (COMPILE-FOO)) 1170 | `((:SECTION :CODE 1171 | ((DEFINE-COMPILER-MACRO ,COMPILE-FOO 1172 | (&WHOLE X) 1173 | X)))) 1174 | ("COMPILE-FOO compiler macro" ((:DEF 0)))) 1175 | (DEFINE-INDEXING-TEST 1176 | (DEFMACRO :VERIFY-WALK () :TOPLEVEL T :AUX (TWIDDLE TWIDDLE-FOO)) 1177 | `((:SECTION :CODE 1178 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) (DEFUN ,TWIDDLE (X) (* X 42))))) 1179 | (:SECTION :CODE 1180 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) (DEFMACRO ,TWIDDLE-FOO (X) (,TWIDDLE X))))) 1181 | (:SECTION :CODE ((,TWIDDLE-FOO 123)))) 1182 | ("TWIDDLE function" (1 (:DEF 0))) ("TWIDDLE-FOO macro" (2 (:DEF 1)))) 1183 | (DEFINE-INDEXING-TEST 1184 | (SYMBOL-MACRO :VERIFY-WALK NIL :TOPLEVEL T :AUX (FOO-BAR-BAZ)) 1185 | `((:SECTION :CODE 1186 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) 1187 | (DEFINE-SYMBOL-MACRO ,FOO-BAR-BAZ (:BAR :BAZ))))) 1188 | (:SECTION :CODE (,FOO-BAR-BAZ))) 1189 | ("FOO-BAR-BAZ symbol macro" (1 (:DEF 0)))) 1190 | (DEFINE-INDEXING-TEST (DEFVAR :VERIFY-WALK NIL :TOPLEVEL T :AUX (SUPER DUPER)) 1191 | `((:SECTION :CODE ((EVAL-WHEN (:COMPILE-TOPLEVEL) (DEFVAR ,SUPER 450)))) 1192 | (:SECTION :CODE 1193 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) (DEFPARAMETER ,DUPER (1+ ,SUPER)))))) 1194 | ("DUPER special variable" ((:DEF 1))) ("SUPER special variable" (1 (:DEF 0)))) 1195 | (DEFINE-INDEXING-TEST 1196 | (DEFCONSTANT :VERIFY-WALK NIL :TOPLEVEL T :AUX (EL-GORDO)) 1197 | `((:SECTION :CODE ((DEFCONSTANT ,EL-GORDO MOST-POSITIVE-FIXNUM)))) 1198 | ("EL-GORDO constant" ((:DEF 0)))) 1199 | (DEFINE-INDEXING-TEST (DEFSTRUCT :VERIFY-WALK NIL :TOPLEVEL T :AUX (FOO)) 1200 | `((:SECTION :CODE ((DEFSTRUCT ,FOO)))) ("COPY-FOO copier function" ((:DEF 0))) 1201 | ("FOO structure" ((:DEF 0))) ("FOO-P type predicate" ((:DEF 0))) 1202 | ("MAKE-FOO constructor function" ((:DEF 0)))) 1203 | (DEFINE-INDEXING-TEST 1204 | ((DEFSTRUCT FUNCTIONS) :VERIFY-WALK NIL :TOPLEVEL T :AUX 1205 | (A B C CONS-C DUP-C CP)) 1206 | `((:SECTION :CODE ((DEFSTRUCT (,A :CONSTRUCTOR (:PREDICATE NIL))))) 1207 | (:SECTION :CODE ((DEFSTRUCT (,B (:CONSTRUCTOR NIL) (:PREDICATE))))) 1208 | (:SECTION :CODE 1209 | ((DEFSTRUCT 1210 | (,C (:CONSTRUCTOR ,CONS-C) (:COPIER ,DUP-C) (:PREDICATE ,CP)))))) 1211 | ("A structure" ((:DEF 0))) ("B structure" ((:DEF 1))) 1212 | ("B-P type predicate" ((:DEF 1))) ("C structure" ((:DEF 2))) 1213 | ("CONS-C constructor function" ((:DEF 2))) 1214 | ("COPY-A copier function" ((:DEF 0))) ("COPY-B copier function" ((:DEF 1))) 1215 | ("CP type predicate" ((:DEF 2))) ("DUP-C copier function" ((:DEF 2))) 1216 | ("MAKE-A constructor function" ((:DEF 0)))) 1217 | (DEFINE-INDEXING-TEST 1218 | ((DEFSTRUCT :INCLUDE) :VERIFY-WALK NIL :TOPLEVEL T :AUX (BASE DERIVED)) 1219 | `((:SECTION :CODE 1220 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) 1221 | (DEFSTRUCT (,BASE (:CONSTRUCTOR NIL) (:COPIER NIL) (:PREDICATE NIL)))))) 1222 | (:SECTION :CODE 1223 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) 1224 | (DEFSTRUCT 1225 | (,DERIVED (:INCLUDE ,BASE) (:CONSTRUCTOR NIL) (:COPIER NIL) 1226 | (:PREDICATE NIL))))))) 1227 | ("BASE structure" (1 (:DEF 0))) ("DERIVED structure" ((:DEF 1)))) 1228 | (DEFINE-INDEXING-TEST 1229 | ((DEFSTRUCT ACCESSORS) :VERIFY-WALK NIL :TOPLEVEL T :AUX (TOWN)) 1230 | `((:SECTION :CODE 1231 | ((DEFSTRUCT ,TOWN 1232 | AREA 1233 | WATERTOWERS 1234 | (FIRETRUCKS 1 :TYPE FIXNUM) 1235 | POPULATION 1236 | (ELEVATION 5128 :READ-ONLY T))))) 1237 | ("COPY-TOWN copier function" ((:DEF 0))) 1238 | ("MAKE-TOWN constructor function" ((:DEF 0))) ("TOWN structure" ((:DEF 0))) 1239 | ("TOWN-AREA slot accessor" ((:DEF 0))) 1240 | ("TOWN-ELEVATION slot reader" ((:DEF 0))) 1241 | ("TOWN-FIRETRUCKS slot accessor" ((:DEF 0))) 1242 | ("TOWN-P type predicate" ((:DEF 0))) 1243 | ("TOWN-POPULATION slot accessor" ((:DEF 0))) 1244 | ("TOWN-WATERTOWERS slot accessor" ((:DEF 0)))) 1245 | (DEFINE-INDEXING-TEST 1246 | ((DEFSTRUCT CONC-NAME) :VERIFY-WALK NIL :TOPLEVEL T :AUX (CLOWN)) 1247 | `((:SECTION :CODE 1248 | ((DEFSTRUCT (,CLOWN (:CONC-NAME BOZO-)) 1249 | (NOSE-COLOR 'RED) 1250 | FRIZZY-HAIR-P 1251 | POLKADOTS)))) 1252 | ("BOZO-FRIZZY-HAIR-P slot accessor" ((:DEF 0))) 1253 | ("BOZO-NOSE-COLOR slot accessor" ((:DEF 0))) 1254 | ("BOZO-POLKADOTS slot accessor" ((:DEF 0))) ("CLOWN structure" ((:DEF 0))) 1255 | ("CLOWN-P type predicate" ((:DEF 0))) 1256 | ("COPY-CLOWN copier function" ((:DEF 0))) 1257 | ("MAKE-CLOWN constructor function" ((:DEF 0)))) 1258 | (DEFINE-INDEXING-TEST 1259 | ((DEFSTRUCT INHERITED-ACCESSOR) :VERIFY-WALK NIL :TOPLEVEL T :AUX (A B)) 1260 | `((:SECTION :CODE 1261 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) 1262 | (DEFSTRUCT 1263 | (,A (:CONC-NAME NIL) (:CONSTRUCTOR NIL) (:COPIER NIL) 1264 | (:PREDICATE NIL)) 1265 | A-B)))) 1266 | (:SECTION :CODE 1267 | ((EVAL-WHEN (:COMPILE-TOPLEVEL) 1268 | (DEFSTRUCT 1269 | (,B (:INCLUDE ,A) (:CONC-NAME A-) (:CONSTRUCTOR NIL) (:COPIER NIL) 1270 | (:PREDICATE NIL)) 1271 | (B NIL :READ-ONLY T)))))) 1272 | ("A structure" (1 (:DEF 0))) ("A-B slot accessor" ((:DEF 0))) 1273 | ("B structure" ((:DEF 1)))) 1274 | (DEFINE-INDEXING-TEST 1275 | (DEFGENERIC :AUX 1276 | (FOO)) 1277 | `((:SECTION :CODE 1278 | ((DEFGENERIC ,FOO 1279 | (X Y) 1280 | (:DOCUMENTATION "foo") 1281 | (:METHOD-COMBINATION PROGN) 1282 | (:METHOD PROGN ((X T) Y) X) 1283 | (:METHOD :AROUND (X (Y (EQL 'T))) Y)))) 1284 | (:SECTION :CODE ((,FOO 2 3))) 1285 | (:SECTION :CODE 1286 | ((DEFGENERIC (SETF ,FOO) 1287 | (NEW X Y))))) 1288 | ("FOO around method" ((:DEF 0))) ("FOO generic function" (1 (:DEF 0))) 1289 | ("FOO generic setf function" ((:DEF 2))) ("FOO progn method" ((:DEF 0)))) 1290 | (DEFTEST GENERIC-FUNCTION-P 1291 | (VALUES (NOT (NULL (GENERIC-FUNCTION-P 'MAKE-INSTANCE))) 1292 | (NULL (GENERIC-FUNCTION-P '#:FOO)) 1293 | (NOT (NULL (GENERIC-FUNCTION-P (NOTE-GENERIC-FUNCTION '#:FOO))))) 1294 | T T T) 1295 | (DEFMETHOD PRINT-OBJECT ((X METHOD-NAME) STREAM) 1296 | (PRINT-UNREADABLE-OBJECT (X STREAM :TYPE T :IDENTITY T) 1297 | (PRIN1 (METHOD-QUALIFIER-NAMES X) STREAM))) 1298 | (DEFINE-INDEXING-TEST (DEFMETHOD :AUX (FOO)) 1299 | `((:SECTION :CODE ((DEFMETHOD ,FOO (X Y) (+ X Y)))) 1300 | (:SECTION :CODE ((DEFMETHOD ,FOO :BEFORE (X Y)))) 1301 | (:SECTION :CODE ((DEFMETHOD (SETF ,FOO) (NEW-FOO FOO) NEW-FOO))) 1302 | (:SECTION :CODE ((FUNCALL #'(SETF ,FOO) Y X)))) 1303 | ("FOO before method" ((:DEF 1))) ("FOO generic setf function" (3)) 1304 | ("FOO primary method" ((:DEF 0))) ("FOO primary setf method" ((:DEF 2)))) 1305 | (DEFINE-INDEXING-TEST 1306 | (DEFCLASS :VERIFY-WALK NIL :AUX (FOO BAR A B FOO-A1 FOO-A2 FOO-B)) 1307 | `((:SECTION :CODE 1308 | ((DEFCLASS ,FOO NIL ((,A :READER ,FOO-A1 :READER ,FOO-A2))))) 1309 | (:SECTION :CODE 1310 | ((DEFINE-CONDITION ,BAR 1311 | NIL 1312 | ((,B :ACCESSOR ,FOO-B)))))) 1313 | ("BAR condition class" ((:DEF 1))) ("FOO class" ((:DEF 0))) 1314 | ("FOO-A1 reader method" ((:DEF 0))) ("FOO-A2 reader method" ((:DEF 0))) 1315 | ("FOO-B accessor method" ((:DEF 1)))) 1316 | (DEFINE-INDEXING-TEST 1317 | (DEFINE-METHOD-COMBINATION :VERIFY-WALK NIL :AUX (FOO GENERIC-FOO)) 1318 | `((:SECTION :CODE ((DEFINE-METHOD-COMBINATION ,FOO))) 1319 | (:SECTION :CODE 1320 | ((DEFGENERIC ,GENERIC-FOO 1321 | NIL 1322 | (:METHOD-COMBINATION ,FOO))))) 1323 | ("FOO method combination" (1 (:DEF 0))) 1324 | ("GENERIC-FOO generic function" ((:DEF 1)))) 1325 | (DEFMETHOD LOCATION ((RANGE SECTION-RANGE)) 1326 | (LIST (START-SECTION RANGE) (END-SECTION RANGE))) 1327 | (DEFTEST (COALESCE-LOCATORS 1) 1328 | (MAPCAR 1329 | (LAMBDA (SECTIONS) 1330 | (MAPCAR #'LOCATION 1331 | (COALESCE-LOCATORS 1332 | (MAPCAR (LAMBDA (N) (MAKE-INSTANCE 'SECTION-LOCATOR :SECTION N)) 1333 | SECTIONS)))) 1334 | '((1 3 5 7) (1 2 3 5 7) (1 3 4 5 7) (1 2 3 5 6 7) (1 2 3 5 6 7 9))) 1335 | ((1 3 5 7) ((1 3) 5 7) (1 (3 5) 7) ((1 3) (5 7)) ((1 3) (5 7) 9))) 1336 | (DEFTEST (COALESCE-LOCATORS 2) 1337 | (MAPCAR #'LOCATION 1338 | (COALESCE-LOCATORS 1339 | `(,(MAKE-INSTANCE 'SECTION-LOCATOR :SECTION 1 :DEF T) 1340 | ,@(MAPCAR (LAMBDA (N) (MAKE-INSTANCE 'SECTION-LOCATOR :SECTION N)) 1341 | '(2 3 5)) 1342 | ,(MAKE-INSTANCE 'SECTION-LOCATOR :SECTION 6 :DEF T)))) 1343 | (1 (2 3) 5 6)) 1344 | (DEFTEST MACRO-CHAR-HEADING-LESSP 1345 | (LET* ((A (MAKE-MACRO-CHAR-HEADING #\a)) 1346 | (B (MAKE-MACRO-CHAR-HEADING #\b)) 1347 | (AB (MAKE-MACRO-CHAR-HEADING #\a #\b)) 1348 | (AC (MAKE-MACRO-CHAR-HEADING #\a #\c))) 1349 | (EVERY #'IDENTITY 1350 | (LIST (ENTRY-HEADING-STRICTLY-LESSP A B) 1351 | (NOT (ENTRY-HEADING-STRICTLY-LESSP B A)) 1352 | (ENTRY-HEADING-STRICTLY-LESSP A AB) 1353 | (ENTRY-HEADING-STRICTLY-LESSP B AB) 1354 | (NOT (ENTRY-HEADING-STRICTLY-LESSP AB AB)) 1355 | (ENTRY-HEADING-STRICTLY-LESSP AB AC)))) 1356 | T) 1357 | (DEFTEST MACRO-CHAR-HEADING-EQUALP 1358 | (LET* ((A (MAKE-MACRO-CHAR-HEADING #\a)) 1359 | (B (MAKE-MACRO-CHAR-HEADING #\b)) 1360 | (AB (MAKE-MACRO-CHAR-HEADING #\a #\b))) 1361 | (EVERY #'IDENTITY 1362 | (LIST (ENTRY-HEADING-SYMMETRIC-EQUALP A A) 1363 | (ENTRY-HEADING-SYMMETRIC-UNEQUALP A B) 1364 | (ENTRY-HEADING-SYMMETRIC-UNEQUALP B A) 1365 | (ENTRY-HEADING-SYMMETRIC-UNEQUALP A AB) 1366 | (ENTRY-HEADING-SYMMETRIC-EQUALP AB AB)))) 1367 | T) 1368 | (DEFINE-INDEXING-TEST MACRO-CHARACTER 1369 | '((:SECTION :CODE ((SET-MACRO-CHARACTER #\! '#:READ-BANG))) 1370 | (:SECTION :CODE ((SET-DISPATCH-MACRO-CHARACTER #\@ #\! '#:READ-AT-BANG)))) 1371 | ("!" ((:DEF 0))) ("@ !" ((:DEF 1)))) -------------------------------------------------------------------------------- /clweb.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for CLWEB, a literate programming system for -*-Lisp-*- 2 | 3 | (defsystem clweb 4 | :description "A literate programming system for Common Lisp" 5 | :version "1.0" 6 | :author "Alex Plotnick" 7 | :license "MIT" 8 | :depends-on ((:version "asdf" 3.1.2) 9 | (:feature :sbcl "sb-cltl2")) 10 | :components ((:static-file "LICENSE") 11 | (:static-file "README") 12 | (:file "clweb") 13 | (:file "asdf-operations" :depends-on ("clweb")))) 14 | 15 | (defmethod perform :after ((op load-op) (component (eql (find-system 'clweb)))) 16 | (provide 'clweb)) 17 | 18 | (defmethod perform ((op test-op) (component (eql (find-system 'clweb)))) 19 | (load-system 'clweb/tests) 20 | (test-system 'clweb/tests)) 21 | 22 | (defsystem clweb/tests 23 | :description "CLWEB regression test suite" 24 | :depends-on ("clweb") 25 | :components ((:file "rt") 26 | (:file "clweb-tests" :depends-on ("rt")))) 27 | 28 | (defmethod perform ((op test-op) (component (eql (find-system 'clweb/tests)))) 29 | (symbol-call 'clweb 'do-tests)) 30 | -------------------------------------------------------------------------------- /clweb.el: -------------------------------------------------------------------------------- 1 | ;;;; A major-mode for editing CLWEB programs. 2 | 3 | (defvar start-section-regexp "^@\\([0-9]*\\)\\([ *\nTt]\\)") 4 | (defvar start-non-test-section-regexp "^@\\([0-9]*\\)\\([ *\n]\\)") 5 | 6 | (defun move-by-sections (arg &optional skip-test-sections) 7 | "Move forward or backward ARG sections." 8 | (let ((regexp (if skip-test-sections 9 | start-non-test-section-regexp 10 | start-section-regexp))) 11 | (cond ((> arg 0) 12 | (condition-case nil 13 | (re-search-forward regexp nil nil 14 | (if (looking-at start-section-regexp) 15 | (1+ arg) 16 | arg)) 17 | (search-failed (signal 'end-of-buffer nil))) 18 | (goto-char (match-beginning 0))) 19 | ((< arg 0) 20 | (condition-case nil 21 | (re-search-backward regexp nil nil (- arg)) 22 | (search-failed (signal 'beginning-of-buffer nil))) 23 | (point))))) 24 | 25 | (defun forward-section (arg) 26 | "Move forward to the beginning of the next web section. 27 | With argument, do this that many times." 28 | (interactive "p") 29 | (move-by-sections arg)) 30 | 31 | (defun backward-section (arg) 32 | "Move backward to the beginning of a web section. 33 | With argument, do this that many times." 34 | (interactive "p") 35 | (move-by-sections (- arg))) 36 | 37 | (defun goto-section (arg) 38 | "Move to the section whose number is the given argument." 39 | (interactive "NSection number: ") 40 | (goto-char 1) 41 | (condition-case nil 42 | (move-by-sections arg t) 43 | (end-of-buffer (goto-char (point-max))))) 44 | 45 | (defun what-section () 46 | "Print the section number containing point." 47 | (interactive) 48 | (let ((p (point)) 49 | (n -1)) 50 | (save-excursion 51 | (save-restriction 52 | (widen) 53 | (goto-char 1) 54 | (condition-case nil 55 | (while (<= (point) p) 56 | (setq n (1+ n)) 57 | (move-by-sections 1 t)) 58 | (end-of-buffer)))) 59 | (message "%d" n))) 60 | 61 | (defcustom clweb-inferior-lisp-method 'inferior-lisp 62 | "The inferior Lisp method used to evaluate CLWEB sections. 63 | One of the symbols INFERIOR-LISP, ELI, or SLIME." 64 | :type 'symbol) 65 | 66 | (defun eval-section (arg) 67 | "Evaluate the (named or unnamed) section around point. 68 | If an argument is supplied, code for named sections will be appended to 69 | any existing code for that section; otherwise, it will be replaced." 70 | (interactive "P") 71 | (save-excursion 72 | (let* ((start (condition-case nil 73 | (if (looking-at start-section-regexp) 74 | (point) 75 | (move-by-sections -1)) 76 | (beginning-of-buffer (error "In limbo")))) 77 | (end (condition-case nil 78 | (move-by-sections 1) 79 | (end-of-buffer (point-max)))) 80 | (temp-file (make-temp-file "clweb"))) 81 | (write-region start end temp-file t 'nomsg) 82 | (let ((string (format "(clweb:load-sections-from-temp-file %S %S)" 83 | temp-file (not (null arg))))) 84 | (cond ((and (eq clweb-inferior-lisp-method 'slime) 85 | (fboundp 'slime-interactive-eval)) 86 | (slime-interactive-eval string)) 87 | ((and (eq clweb-inferior-lisp-method 'eli) 88 | (fboundp 'fi:eval-in-lisp)) 89 | (fi:eval-in-lisp string)) 90 | ((and (eq clweb-inferior-lisp-method 'inferior-lisp) 91 | (fboundp 'inferior-lisp-proc)) 92 | (comint-simple-send (inferior-lisp-proc) string)) 93 | (t (error "Unable to find superior or inferior Lisp"))))))) 94 | 95 | 96 | (defun insert-named-section (&optional section-name) 97 | "Insert a CLWEB @ at point." 98 | (interactive "sSection name: ") 99 | (insert (format "@<%s@>" section-name)) 100 | (when (or (null section-name) (string= section-name "")) 101 | ;; Back up point over "@>" for convenient name input. 102 | (backward-char 2))) 103 | 104 | (define-derived-mode clweb-mode lisp-mode "CLWEB" 105 | "Major mode for editing CLWEB programs. 106 | \\{clweb-mode-map}" 107 | (setq fill-paragraph-function nil) 108 | (set (make-local-variable 'parse-sexp-lookup-properties) t) 109 | (set (make-local-variable 'outline-regexp) start-non-test-section-regexp) 110 | (set (make-local-variable 'outline-level) 'clweb-outline-level) 111 | (setq info-lookup-mode 'lisp-mode) 112 | (setq font-lock-defaults 113 | '((lisp-font-lock-keywords 114 | lisp-font-lock-keywords-1 115 | lisp-font-lock-keywords-2) 116 | nil 117 | nil 118 | (("+-/.!?$%_&~^:" . "w")) 119 | nil 120 | (font-lock-mark-block-function . mark-defun) 121 | (font-lock-syntactic-face-function 122 | . lisp-font-lock-syntactic-face-function) 123 | (font-lock-syntactic-keywords 124 | . (("\\(^\\|[^@,]\\)\\(@[0-9]*\\)[ *Tt]" 2 "< b") 125 | ("\\(^\\|[^@]\\)@\\([LlPp]\\)" 2 "> b") 126 | ("\\(^\\|[^@]\\)\\(@\\)[<^.]" 2 "< bn") 127 | ("\\(^\\|[^@]\\)@\\(>\\)[^=]" 2 "> bn") 128 | ("\\(^\\|[^@]\\)@\\(>\\)\\+?\\(=\\)" (2 "> bn") (3 "> b"))))))) 129 | 130 | (defun clweb-outline-level () 131 | "CLWEB mode `outline-level' function." 132 | (if (string= (match-string 2) "*") 133 | (1+ (string-to-number (match-string 1))) 134 | ;; Searching backward for the last starred section seems silly. 135 | 1000)) 136 | 137 | (define-key clweb-mode-map "\C-c\C-n" 'forward-section) 138 | (define-key clweb-mode-map "\C-c\C-p" 'backward-section) 139 | (define-key clweb-mode-map "\C-c\C-s" 'eval-section) 140 | (define-key clweb-mode-map "\C-c\C-i" 'insert-named-section) 141 | 142 | (add-to-list 'auto-mode-alist '("\\.clw" . clweb-mode)) 143 | 144 | (eval-after-load 'slime-repl 145 | '(progn 146 | (defslime-repl-shortcut clweb-weave ("weave") 147 | (:handler (lambda (filename) 148 | (interactive 149 | (list (expand-file-name 150 | (read-file-name "File: " nil nil nil nil)))) 151 | (slime-save-some-lisp-buffers) 152 | (slime-repl-shortcut-eval 153 | `(cl:namestring 154 | (clweb:weave ,(slime-to-lisp-filename filename)))))) 155 | (:one-liner "Weave a web.")) 156 | (defslime-repl-shortcut clweb-tangle-and-load ("tangle-and-load" "tl") 157 | (:handler (lambda (filename) 158 | (interactive 159 | (list (expand-file-name 160 | (read-file-name "File: " nil nil nil nil)))) 161 | (slime-save-some-lisp-buffers) 162 | (slime-repl-shortcut-eval 163 | `(cl:load 164 | (clweb:tangle-file 165 | ,(slime-to-lisp-filename filename)))))) 166 | (:one-liner "Tangle and load a web.")))) 167 | 168 | (provide 'clweb) 169 | -------------------------------------------------------------------------------- /clwebmac.tex: -------------------------------------------------------------------------------- 1 | \input cwebmac 2 | 3 | \font\eightit=cmti8 4 | \font\tenss=cmss10 5 | \font\tenssi=cmssi10 6 | \font\tenssb=cmssdc10 7 | \let\cmntfont=\tenrm 8 | \def\mainfont{\def\rm{\fam0\tenrm}% 9 | \def\it{\fam\itfam\tenit}% 10 | \def\bf{\fam\bffam\tenbf}% 11 | \normalbaselines\rm} 12 | \def\codefont{\def\rm{\fam0\tenss}% 13 | \def\it{\fam\itfam\tenssi}% 14 | \def\bf{\fam\bffam\tenssb}% 15 | \normalbaselines\rm} 16 | \mainfont 17 | 18 | \def\1{\hskip.5em\relax} % indent one level 19 | \def\2{\hskip1.5em\relax} % indent two levels 20 | \def\6{\ifmmode\else\par\ignorespaces\fi} % forced break 21 | 22 | {\catcode`\(=\active \catcode`\)=\active 23 | \gdef({{\rm\char`\(}\kern.025em} 24 | \gdef){\/{\rm\char`\)}\kern.025em} 25 | \gdef\activeparens{\catcode`\(=\active \catcode`\)=\active}} 26 | {\catcode`\*=\active 27 | \gdef\activestar{\catcode`\*=\active \def*{\leavevmode$\ast$}}} 28 | {\obeyspaces\global\let =\ } % let active space = control space 29 | 30 | \def\B{\bgroup % go into Lisp mode 31 | \rightskip=0pt plus 100pt minus 10pt 32 | \parindent=0pt 33 | \pretolerance 10000 34 | \hyphenpenalty 1000 % so strings can be broken (discretionary \ is inserted) 35 | \exhyphenpenalty 10000 36 | \let\!=\cleartabs 37 | \IB} 38 | \def\IB{\activeparens\activestar 39 | \def\#{\char`\#}% sharpsign 40 | \def\&{\char`\&}% ampersand 41 | \def\:##1{\hbox{\it :##1\/\kern.05em}}% keyword symbol 42 | \def\'{'\kern.025em}% quote 43 | \def\`{\char'22}% use grave accent for backquote 44 | \codefont\obeyspaces} 45 | \def\({\bgroup\IB\it} % go into inner-Lisp mode 46 | \def\){\/\egroup} % end inner-Lisp mode 47 | \def\C#1{{\cmntfont #1}} % comment 48 | \def\CH#1{\leavevmode$\backslash$\.{#1}} % character 49 | \def\CO#1{\leavevmode,#1\kern.025em} % comma(-at, -dot) 50 | \def\L{\leavevmode$\lambda$} 51 | \def\K#1{\hbox{\it#1\/\kern.05em}} % lambda-list keyword 52 | \def\RC#1{\hbox{\obeyspaces\tt #1}} % read-time conditional 53 | \def\T{\exnote{This test exercises code in or around {\it\progname\/} section}} 54 | \def\Ts{\exnote{These tests exercise code in or around {\it\progname\/} section}} 55 | \def\X#1:#2\X{\ifmmode\gdef\XX{\null$\null}\else\gdef\XX{}\fi %$% section name 56 | \XX$\langle\,${\mainfont\let\I=\ne#2\eightrm\kern.5em 57 | \ifacro{\pdfnote#1.}\else#1\fi}$\,\rangle$\XX} 58 | 59 | % We don't want to actually make hyperlinks between the test notes and the 60 | % main program sections. 61 | \def\nolink#1#2{#1} 62 | \def\exnote#1#2.{{\let\pdflink\nolink \let\it\eightit \note{#1}{#2}.}} 63 | 64 | \newtoks\srcspc 65 | \def\srcspecial#1{\ifx{}#1\else\special{src:#1}\fi} 66 | \let\oldstartsection=\startsection 67 | \def\startsection{\srcspecial{\the\srcspc}\oldstartsection} 68 | \def\SL[#1]{\srcspc={#1}} 69 | -------------------------------------------------------------------------------- /rt.lisp: -------------------------------------------------------------------------------- 1 | #|----------------------------------------------------------------------------| 2 | | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | 3 | | | 4 | | Permission to use, copy, modify, and distribute this software and its | 5 | | documentation for any purpose and without fee is hereby granted, provided | 6 | | that this copyright and permission notice appear in all copies and | 7 | | supporting documentation, and that the name of M.I.T. not be used in | 8 | | advertising or publicity pertaining to distribution of the software | 9 | | without specific, written prior permission. M.I.T. makes no | 10 | | representations about the suitability of this software for any purpose. | 11 | | It is provided "as is" without express or implied warranty. | 12 | | | 13 | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | 14 | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | 15 | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | 16 | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | 17 | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | 18 | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | 19 | | SOFTWARE. | 20 | |----------------------------------------------------------------------------|# 21 | 22 | (provide :rt) 23 | (defpackage :rt 24 | (:use #:cl) 25 | (:export #:*do-tests-when-defined* #:*test* #:continue-testing 26 | #:deftest #:do-test #:do-tests #:get-test #:pending-tests 27 | #:rem-all-tests #:rem-test) 28 | (:documentation "The MIT regression tester")) 29 | 30 | (in-package :rt) 31 | 32 | (defvar *test* nil "Current test name") 33 | (defvar *do-tests-when-defined* nil) 34 | (defvar *entries* '(nil) "Test database") 35 | (defvar *in-test* nil "Used by TEST") 36 | (defvar *debug* nil "For debugging") 37 | (defvar *catch-errors* t 38 | "When true, causes errors in a test to be caught.") 39 | (defvar *print-circle-on-failure* nil 40 | "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") 41 | (defvar *compile-tests* nil 42 | "When true, compile the tests before running them.") 43 | (defvar *optimization-settings* '((safety 3))) 44 | (defvar *expected-failures* nil 45 | "A list of test names that are expected to fail.") 46 | 47 | (defstruct (entry (:conc-name nil) 48 | (:type list)) 49 | pend name form) 50 | 51 | (defmacro vals (entry) `(cdddr ,entry)) 52 | 53 | (defmacro defn (entry) `(cdr ,entry)) 54 | 55 | (defun pending-tests () 56 | (do ((l (cdr *entries*) (cdr l)) 57 | (r nil)) 58 | ((null l) (nreverse r)) 59 | (when (pend (car l)) 60 | (push (name (car l)) r)))) 61 | 62 | (defun rem-all-tests () 63 | (setq *entries* (list nil)) 64 | nil) 65 | 66 | (defun rem-test (&optional (name *test*)) 67 | (do ((l *entries* (cdr l))) 68 | ((null (cdr l)) nil) 69 | (when (equal (name (cadr l)) name) 70 | (setf (cdr l) (cddr l)) 71 | (return name)))) 72 | 73 | (defun get-test (&optional (name *test*)) 74 | (defn (get-entry name))) 75 | 76 | (defun get-entry (name) 77 | (let ((entry (find name (cdr *entries*) 78 | :key #'name 79 | :test #'equal))) 80 | (when (null entry) 81 | (report-error t 82 | "~%No test with name ~:@(~S~)." 83 | name)) 84 | entry)) 85 | 86 | (defmacro deftest (name form &rest values) 87 | `(add-entry '(t ,name ,form .,values))) 88 | 89 | (defun add-entry (entry) 90 | (setq entry (copy-list entry)) 91 | (do ((l *entries* (cdr l))) (nil) 92 | (when (null (cdr l)) 93 | (setf (cdr l) (list entry)) 94 | (return nil)) 95 | (when (equal (name (cadr l)) 96 | (name entry)) 97 | (setf (cadr l) entry) 98 | (report-error nil 99 | "Redefining test ~:@(~S~)" 100 | (name entry)) 101 | (return nil))) 102 | (when *do-tests-when-defined* 103 | (do-entry entry)) 104 | (setq *test* (name entry))) 105 | 106 | (defun report-error (error? &rest args) 107 | (cond (*debug* 108 | (apply #'format t args) 109 | (if error? (throw '*debug* nil))) 110 | (error? (apply #'error args)) 111 | (t (apply #'warn args)))) 112 | 113 | (defun do-test (&optional (name *test*)) 114 | (do-entry (get-entry name))) 115 | 116 | (defun equalp-with-case (x y) 117 | "Like EQUALP, but doesn't do case conversion of characters." 118 | (cond 119 | ((eq x y) t) 120 | ((consp x) 121 | (and (consp y) 122 | (equalp-with-case (car x) (car y)) 123 | (equalp-with-case (cdr x) (cdr y)))) 124 | ((and (typep x 'array) 125 | (= (array-rank x) 0)) 126 | (equalp-with-case (aref x) (aref y))) 127 | ((typep x 'vector) 128 | (and (typep y 'vector) 129 | (let ((x-len (length x)) 130 | (y-len (length y))) 131 | (and (eql x-len y-len) 132 | (loop 133 | for e1 across x 134 | for e2 across y 135 | always (equalp-with-case e1 e2)))))) 136 | ((and (typep x 'array) 137 | (typep y 'array) 138 | (not (equal (array-dimensions x) 139 | (array-dimensions y)))) 140 | nil) 141 | ((typep x 'array) 142 | (and (typep y 'array) 143 | (let ((size (array-total-size x))) 144 | (loop for i from 0 below size 145 | always (equalp-with-case (row-major-aref x i) 146 | (row-major-aref y i)))))) 147 | ((pathnamep x) 148 | (and (pathnamep y) 149 | (equal x y))) 150 | (t (eql x y)))) 151 | 152 | (defun do-entry (entry &optional 153 | (s *standard-output*)) 154 | (catch '*in-test* 155 | (setq *test* (name entry)) 156 | (setf (pend entry) t) 157 | (let* ((*in-test* t) 158 | ;; (*break-on-warnings* t) 159 | (aborted nil) 160 | r) 161 | ;; (declare (special *break-on-warnings*)) 162 | 163 | (block aborted 164 | (setf r 165 | (flet ((%do 166 | () 167 | (if *compile-tests* 168 | (multiple-value-list 169 | (funcall (compile 170 | nil 171 | `(lambda () 172 | (declare 173 | (optimize ,@*optimization-settings*)) 174 | ,(form entry))))) 175 | (multiple-value-list 176 | (eval (form entry)))))) 177 | (if *catch-errors* 178 | (handler-bind 179 | ((style-warning #'muffle-warning) 180 | (error #'(lambda (c) 181 | (setf aborted t) 182 | (setf r (list c)) 183 | (return-from aborted nil)))) 184 | (%do)) 185 | (%do))))) 186 | 187 | (setf (pend entry) 188 | (or aborted 189 | (not (equalp-with-case r (vals entry))))) 190 | 191 | (when (pend entry) 192 | (let ((*print-circle* *print-circle-on-failure*)) 193 | (format s "~&Test ~:@(~S~) failed~ 194 | ~%Form: ~S~ 195 | ~%Expected value~P: ~ 196 | ~{~S~^~%~17t~}~%" 197 | *test* (form entry) 198 | (length (vals entry)) 199 | (vals entry)) 200 | (format s "Actual value~P: ~ 201 | ~{~S~^~%~15t~}.~%" 202 | (length r) r))))) 203 | (when (not (pend entry)) *test*)) 204 | 205 | (defun continue-testing () 206 | (if *in-test* 207 | (throw '*in-test* nil) 208 | (do-entries *standard-output*))) 209 | 210 | (defun do-tests (&optional 211 | (out *standard-output*)) 212 | (dolist (entry (cdr *entries*)) 213 | (setf (pend entry) t)) 214 | (if (streamp out) 215 | (do-entries out) 216 | (with-open-file 217 | (stream out :direction :output) 218 | (do-entries stream)))) 219 | 220 | (defun do-entries (s) 221 | (format s "~&Doing ~A pending test~:P ~ 222 | of ~A tests total.~%" 223 | (count t (cdr *entries*) 224 | :key #'pend) 225 | (length (cdr *entries*))) 226 | (dolist (entry (cdr *entries*)) 227 | (when (pend entry) 228 | (format s "~@[~<~%~:; ~:@(~S~)~>~]" 229 | (do-entry entry s)))) 230 | (let ((pending (pending-tests)) 231 | (expected-table (make-hash-table :test #'equal))) 232 | (dolist (ex *expected-failures*) 233 | (setf (gethash ex expected-table) t)) 234 | (let ((new-failures 235 | (loop for pend in pending 236 | unless (gethash pend expected-table) 237 | collect pend))) 238 | (if (null pending) 239 | (format s "~&No tests failed.") 240 | (progn 241 | (format s "~&~A out of ~A ~ 242 | total tests failed: ~ 243 | ~:@(~{~<~% ~1:;~S~>~ 244 | ~^, ~}~)." 245 | (length pending) 246 | (length (cdr *entries*)) 247 | pending) 248 | (if (null new-failures) 249 | (format s "~&No unexpected failures.") 250 | (when *expected-failures* 251 | (format s "~&~A unexpected failures: ~ 252 | ~:@(~{~<~% ~1:;~S~>~ 253 | ~^, ~}~)." 254 | (length new-failures) 255 | new-failures))) 256 | )) 257 | (finish-output s) 258 | (null pending)))) 259 | -------------------------------------------------------------------------------- /test.clw: -------------------------------------------------------------------------------- 1 | % Some limbo text. 2 | @*Initialization. 3 | @l 4 | @e 5 | (defpackage "TEST" (:use "COMMON-LISP")) 6 | @e 7 | (in-package "TEST") 8 | 9 | @*Foo. The function |foo| adds twice its argument's value to thrice it. 10 | @l 11 | (defun foo (x) 12 | "The function FOO takes an integer X, and returns the sum of X doubled 13 | and X trebled." 14 | (+ @ @)) 15 | 16 | @ @=2 17 | @ @=(* x @) 18 | @ @=(* x 3) 19 | 20 | @*Bar. The function |bar| returns the first four natural numbers (including 0), 21 | and demonstrates how a named section may be defined piecewise. 22 | @l 23 | (defun bar () '(@)) 24 | 25 | @ @=0 26 | @ @=1 27 | @ @=@ 28 | @ @=3 29 | 30 | @ Here's a form that uses a named section that contains multiple forms 31 | which should be spliced into place. 32 | 33 | @l 34 | (defvar *sum* 35 | (@ 36 | (+ a b c))) 37 | 38 | @ @= 39 | destructuring-bind (a b c &rest args) (bar) (declare (ignore args)) 40 | 41 | @ Here's a section with no code. None at all. Not even a scrap. It exists 42 | just so that we can make sure that in such an eventuality, everything is 43 | copacetic. 44 | 45 | @ This section is just here to use the next one. 46 | @l 47 | @ 48 | 49 | @ And this section is just to be used by the previous one. The |defun| should 50 | be all on one line. 51 | @= 52 | (defun do-some-stuff () ; 53 | (list 'some 'stuff)) 54 | 55 | @ And this one gets used by no one at all. 56 | @=nil 57 | @ Also unused, but with the same name as the last one. 58 | @=() 59 | @ And one more, with a different name. 60 | @=t 61 | 62 | @*Markers. Here we test out some of the trickier markers. 63 | 64 | @l 65 | (defparameter *cons* '(a . b)) 66 | (defparameter *vector* #5(a b c)) 67 | (defparameter *bit-vector* #8*1011 "An octet") 68 | (defparameter *bit-string* #B1011) 69 | (defparameter *deadbeef* #Xdeadbeef) 70 | (defparameter *list* '#.(list 1 2 (let ((x 1)) @))) 71 | (defparameter *impl* #+sbcl "SBCL" #+(not sbcl) "Not SBCL") 72 | 73 | @*Baz. The sole purpose of this section is to exercise some of the 74 | pretty-printing capabilities of |weave|. Note that in inner-Lisp mode, 75 | newlines and such are ignored: 76 | |(defun foo (bar baz) 77 | (baz (apply #'qux bar)))| 78 | 79 | @l 80 | (defun read-stuff-from-file (file &key direction) 81 | (with-open-file (stream file :direction direction) 82 | (loop for x = (read stream nil nil nil) ; |x| is a loop-local variable 83 | while x collect x))) 84 | 85 | ;;; The next function doesn't really do anything very interesting, it 86 | ;;; just contains some examples of how various Common Lisp forms are 87 | ;;; usually indented. And this long, pointless comment is just here to 88 | ;;; span multiple lines at the top-level. 89 | (defun body-forms () 90 | (flet ((lessp (x y) 91 | (< x 92 | y)) 93 | (three-values () 94 | (values 1 2 3))) 95 | ;; This multi-line comment is here only to span multiple lines, 96 | ;; like the one just before the start of this |defun|, only not 97 | ;; at the top-level. 98 | (multiple-value-bind (a 99 | b 100 | c) 101 | (three-values) 102 | (foo a) 103 | (lessp b c)))) 104 | 105 | (defmacro backq-forms (foo bar list &aux (var (gensym))) 106 | `(dolist (,var ,list ,list) 107 | (funcall ,foo ,@bar ,var))) 108 | 109 | (defun list-length-example (x) 110 | (do ((n 0 (+ n 2)) 111 | (fast x (cddr fast)) 112 | (slow x (cdr slow))) 113 | (nil) 114 | (when (endp fast) (return n)) 115 | (when (endp (cdr fast)) (return (+ n 1))) 116 | (when (and (eq fast slow) (> n 0)) (return nil)))) 117 | 118 | @ @l 119 | "Here's a top-level string 120 | split over two lines." 121 | 122 | @ Read-time conditionals are also tricky, especially when they span 123 | multiple lines. 124 | 125 | @l 126 | (eval-when (:compile-toplevel :load-toplevel :execute) 127 | #+(or foo bar baz) 128 | (frob this 129 | that 130 | and-another)) 131 | 132 | @*Index tests. 133 | 134 | @ @l 135 | (eval-when (:compile-toplevel :load-toplevel :execute) 136 | (defun count-em (list) (length list))) 137 | (define-symbol-macro three-bears '(:fred :jerry :samuel)) 138 | (defmacro how-many-bears () `(count-em three-bears)) 139 | 140 | (defgeneric generic-foo (foo)) 141 | 142 | (defclass bear () ()) 143 | (defmacro define-bear-class (bear) `(defclass ,bear (bear) ())) 144 | 145 | @ @l 146 | (defun too-many-bears-p (n) (> n (how-many-bears))) 147 | 148 | (defun compute-foo-generically (foo) (generic-foo foo)) 149 | 150 | (define-bear-class grizzly) 151 | 152 | @ @l 153 | (macrolet ((gently-frob (x) `(1+ ,x))) 154 | @) 155 | 156 | @ @= 157 | (gently-frob 27) 158 | 159 | @*Index. 160 | --------------------------------------------------------------------------------