From pbrochard at common-lisp.net Fri Aug 6 22:08:14 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 06 Aug 2010 18:08:14 -0400 Subject: [clfswm-cvs] r286 - in clfswm: . src Message-ID: Author: pbrochard Date: Fri Aug 6 18:08:14 2010 New Revision: 286 Log: big summer commit Modified: clfswm/Makefile.template clfswm/src/tools.lisp Modified: clfswm/Makefile.template ============================================================================== --- clfswm/Makefile.template (original) +++ clfswm/Makefile.template Fri Aug 6 18:08:14 2010 @@ -25,8 +25,11 @@ mkdir -p $(DESTDIR)/bin @echo "2) Installing: Copying files" cp -R `pwd`/load.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ - cp -R `pwd`/src/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/src + cp -R `pwd`/clfswm.asd $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/src/*.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/src cp -R `pwd`/contrib/* $(DESTDIR)/lib/$(PROJECT_NAME)/contrib + @sleep 1 + cp -R `pwd`/src/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/src @echo "3) Installing: Creating starter script" echo "#!/bin/sh" > $(DESTDIR)/bin/$(PROJECT_NAME) echo "$(LISP) $(CORE) $(LOAD_OPT) $(DESTDIR)/lib/$(PROJECT_NAME)/load.lisp" >> $(DESTDIR)/bin/$(PROJECT_NAME) @@ -41,7 +44,7 @@ rm -rf $(DESTDIR)/lib/$(PROJECT_NAME)/ clean: - find . \( -name *~ -o -name *.fas -o -name *.fasl -o -name *.lib -o -name *.lx32fsl -o -name *.x86f \) -print0 | xargs -0 rm -f + find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f dist: clean cd .. && tar czvf $(PROJECT_NAME)-`date +%y%m%d`.tar.gz $(PROJECT_NAME) Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Fri Aug 6 18:08:14 2010 @@ -32,6 +32,8 @@ :awhen :aif :nfuncall + :pfuncall + :symbol-search :call-hook :add-hook :remove-hook @@ -115,6 +117,15 @@ (when function (funcall function))) +(defun pfuncall (function &rest args) + (when (or (functionp function) + (and (symbolp function) (fboundp function))) + (apply function args))) + + +(defun symbol-search (search symbol) + "Search the string 'search' in the symbol name of 'symbol'" + (search search (symbol-name symbol) :test #'string-equal)) ;;;,----- ;;;| Minimal hook From pbrochard at common-lisp.net Thu Aug 12 21:30:53 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 12 Aug 2010 17:30:53 -0400 Subject: [clfswm-cvs] r287 - in clfswm/contrib: . server Message-ID: Author: pbrochard Date: Thu Aug 12 17:30:52 2010 New Revision: 287 Log: Add a clfswm server/client Added: clfswm/contrib/server/ clfswm/contrib/server/Makefile clfswm/contrib/server/Makefile.template clfswm/contrib/server/clfswm-client.asd clfswm/contrib/server/clfswm-client.fas clfswm/contrib/server/clfswm-client.lib clfswm/contrib/server/clfswm-client.lisp clfswm/contrib/server/configure (contents, props changed) clfswm/contrib/server/crypt.fas clfswm/contrib/server/crypt.lib clfswm/contrib/server/crypt.lisp clfswm/contrib/server/key.fas clfswm/contrib/server/key.lib clfswm/contrib/server/key.lisp clfswm/contrib/server/load.lisp clfswm/contrib/server/md5.fas clfswm/contrib/server/md5.lib clfswm/contrib/server/md5.lisp clfswm/contrib/server/net.fas clfswm/contrib/server/net.lib clfswm/contrib/server/net.lisp clfswm/contrib/server/server.lisp clfswm/contrib/server/test.sh (contents, props changed) clfswm/contrib/server/test2.sh (contents, props changed) clfswm/contrib/server/util-server.asd Modified: clfswm/contrib/README Modified: clfswm/contrib/README ============================================================================== --- clfswm/contrib/README (original) +++ clfswm/contrib/README Thu Aug 12 17:30:52 2010 @@ -1,9 +1,9 @@ The contrib directory is here if you want to contribute to CLFSWM and if your code is not merged in the clfswm core. -To contribute, place your files in the contrib directory. +To contribute, place your files in the contrib directory. You can have your own repository and tell me if you want to merge it -in the clfswm svn. +in the clfswm svn/git. To use a contributed code add a line like this in your configuration file: Added: clfswm/contrib/server/Makefile ============================================================================== --- (empty file) +++ clfswm/contrib/server/Makefile Thu Aug 12 17:30:52 2010 @@ -0,0 +1,49 @@ +# -*- makefile -*- +PROJECT_NAME=clfswm-client +DESTDIR=/tmp/local + +LISP=/usr/bin/clisp +EVAL_OPT=-x -q +LOAD_OPT= +EXT=fas +CORE= +EXTRA_OPT= + +all: build + @echo "ALL" + +build: + @echo "Building" + $(LISP) $(CORE) $(EVAL_OPT) '(progn (pushnew :BUILD *features*) (load "load.lisp") (quit))' + @echo "" + @echo "Type 'make install' to install $(PROJECT_NAME) in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + +install: + @echo "1) Installing: Creating directories" + mkdir -p $(DESTDIR)/lib/$(PROJECT_NAME)/ + mkdir -p $(DESTDIR)/bin + @echo "2) Installing: Copying files" + cp -R `pwd`/../asdf.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.asd $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + @sleep 1 + cp -R `pwd`/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/ + @echo "3) Installing: Creating starter script" + echo "#!/bin/sh" > $(DESTDIR)/bin/$(PROJECT_NAME) + echo "$(LISP) $(CORE) $(LOAD_OPT) $(DESTDIR)/lib/$(PROJECT_NAME)/load.lisp $(EXTRA_OPT) \"\$$*\"" >> $(DESTDIR)/bin/$(PROJECT_NAME) + chmod a+x $(DESTDIR)/bin/$(PROJECT_NAME) + @echo "" + @echo "$(PROJECT_NAME) has been installed in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + + +uninstall: + rm -rf $(DESTDIR)/bin/$(PROJECT_NAME) + rm -rf $(DESTDIR)/lib/$(PROJECT_NAME)/ + +clean: + find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f + +dist: clean + cd .. && tar czvf $(PROJECT_NAME)-`date +%y%m%d`.tar.gz $(PROJECT_NAME) Added: clfswm/contrib/server/Makefile.template ============================================================================== --- (empty file) +++ clfswm/contrib/server/Makefile.template Thu Aug 12 17:30:52 2010 @@ -0,0 +1,49 @@ +# -*- makefile -*- +PROJECT_NAME=+PROJECT_NAME+ +DESTDIR=+DESTDIR+ + +LISP=+LISP+ +EVAL_OPT=+EVAL_OPT+ +LOAD_OPT=+LOAD_OPT+ +EXT=+EXT+ +CORE=+CORE+ +EXTRA_OPT=+EXTRA_OPT+ + +all: build + @echo "ALL" + +build: + @echo "Building" + $(LISP) $(CORE) $(EVAL_OPT) '(progn (pushnew :BUILD *features*) (load "load.lisp") (quit))' + @echo "" + @echo "Type 'make install' to install $(PROJECT_NAME) in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + +install: + @echo "1) Installing: Creating directories" + mkdir -p $(DESTDIR)/lib/$(PROJECT_NAME)/ + mkdir -p $(DESTDIR)/bin + @echo "2) Installing: Copying files" + cp -R `pwd`/../asdf.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.asd $(DESTDIR)/lib/$(PROJECT_NAME)/ + cp -R `pwd`/*.lisp $(DESTDIR)/lib/$(PROJECT_NAME)/ + @sleep 1 + cp -R `pwd`/*.$(EXT) $(DESTDIR)/lib/$(PROJECT_NAME)/ + @echo "3) Installing: Creating starter script" + echo "#!/bin/sh" > $(DESTDIR)/bin/$(PROJECT_NAME) + echo "$(LISP) $(CORE) $(LOAD_OPT) $(DESTDIR)/lib/$(PROJECT_NAME)/load.lisp $(EXTRA_OPT) \"\$$*\"" >> $(DESTDIR)/bin/$(PROJECT_NAME) + chmod a+x $(DESTDIR)/bin/$(PROJECT_NAME) + @echo "" + @echo "$(PROJECT_NAME) has been installed in '$(DESTDIR)/bin/$(PROJECT_NAME)'" + @echo "" + + +uninstall: + rm -rf $(DESTDIR)/bin/$(PROJECT_NAME) + rm -rf $(DESTDIR)/lib/$(PROJECT_NAME)/ + +clean: + find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f + +dist: clean + cd .. && tar czvf $(PROJECT_NAME)-`date +%y%m%d`.tar.gz $(PROJECT_NAME) Added: clfswm/contrib/server/clfswm-client.asd ============================================================================== --- (empty file) +++ clfswm/contrib/server/clfswm-client.asd Thu Aug 12 17:30:52 2010 @@ -0,0 +1,20 @@ +;;;; -*- Mode: Lisp -*- +;;;; ASDF System Definition +;;; + +(in-package #:asdf) + +(defsystem clfswm-client + :description "" + :licence "GNU Lesser General Public License (LGPL)" + :components ((:file "clfswm-client")) + :depends-on (util-server)) + + + + + + + + + Added: clfswm/contrib/server/clfswm-client.fas ============================================================================== --- (empty file) +++ clfswm/contrib/server/clfswm-client.fas Thu Aug 12 17:30:52 2010 @@ -0,0 +1,159 @@ +(|SYSTEM|::|VERSION| '(20080430.)) +#0Y_ #0Y |CHARSET|::|UTF-8| +#Y(#:|1 1 (IN-PACKAGE :COMMON-LISP-USER)-1| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("COMMON-LISP-USER" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 4 (DEFPACKAGE :CLFSWM-CLIENT (:USE :COMMON-LISP :CRYPT))-2-1| + #18Y(00 00 00 00 00 00 00 00 20 01 DA 01 04 31 F0 3E 19 01) + ("CLFSWM-CLIENT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 4 (DEFPACKAGE :CLFSWM-CLIENT (:USE :COMMON-LISP :CRYPT))-2-2| + #17Y(00 00 00 00 00 00 00 00 20 01 DA DB 31 EC 3E 19 01) + (("COMMON-LISP" "CRYPT") "CLFSWM-CLIENT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 4 (DEFPACKAGE :CLFSWM-CLIENT (:USE :COMMON-LISP :CRYPT))-2-3| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 D9 19 01) ("CLFSWM-CLIENT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) +#Y(#:|6 6 (IN-PACKAGE :CLFSWM-CLIENT)-3| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("CLFSWM-CLIENT" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|8 18 (DEFUN ARGS NIL ...)-4| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CLFSWM-CLIENT|::|ARGS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CLFSWM-CLIENT|::|ARGS| #14Y(00 00 00 00 00 00 00 00 26 01 0E 00 19 01) + (|EXT|::|*ARGS*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) () + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|20 27 (DEFUN UQUIT NIL ...)-5| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CLFSWM-CLIENT|::|UQUIT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CLFSWM-CLIENT|::|UQUIT| #14Y(00 00 00 00 00 00 00 00 26 01 2E 00 19 01) + (|EXT|::|QUIT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|31 31 (DEFPARAMETER *SERVER-PORT* 33333)-6| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB DC 31 5A C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |CLFSWM-CLIENT|::|*SERVER-PORT*|) + |CLFSWM-CLIENT|::|*SERVER-PORT*| 33333.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|33 38 (DEFUN PRINT-OUTPUT (SOCK &OPTIONAL WAIT) ...)-7| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CLFSWM-CLIENT|::|PRINT-OUTPUT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT| + #114Y(03 00 01 00 01 00 01 00 26 08 00 2B 01 7F 03 00 00 3B 02 07 7D 02 + 93 02 05 1B 2B 92 02 28 47 00 23 AE 6D 01 01 B0 6D 02 01 57 03 B0 + 36 00 16 06 48 1F 3D 1B 11 58 67 00 00 01 76 00 AD 36 01 18 03 01 + 19 02 1F 2A 47 00 10 AE 6D 04 01 B0 6D 05 01 57 06 B0 36 00 16 06 + 48 14 9D 1F 11 E1 6B 08 AE 6B 09 70 0A 33 02 15 38 01 31 9B 19 05 + 19 05 19 04) + (|COMMON-LISP|::|NIL| + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-1| + #16Y(00 00 00 00 00 00 00 00 26 01 DA 2C 01 01 19 01) + (|COMMON-LISP|::|NIL| + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-1-1| + #13Y(00 00 00 00 01 00 00 00 26 02 00 49 00) + (|COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|CONDITION|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) () + |COMMON-LISP|::|NIL| 1) + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-2| + #17Y(00 00 00 00 00 00 00 00 26 01 69 00 01 31 86 19 01) + (|COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1) + (#(|COMMON-LISP|::|ERROR| 43.) 2. . 1.) + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-3| + #16Y(00 00 00 00 00 00 00 00 26 01 DA 2C 01 01 19 01) + (|COMMON-LISP|::|NIL| + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-3-1| + #13Y(00 00 00 00 01 00 00 00 26 02 00 49 00) + (|COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|CONDITION|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) () + |COMMON-LISP|::|NIL| 1) + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-4| + #24Y(00 00 00 00 00 00 00 00 26 01 DB 69 00 01 01 02 38 01 71 82 30 + 02 19 01) + (|COMMON-LISP|::|NIL| (#\Newline) |COMMON-LISP|::|STRING-TRIM|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1) + (#(|COMMON-LISP|::|ERROR| 43.) 2. . 1.) + #Y(|CLFSWM-CLIENT|::|PRINT-OUTPUT-5| + #20Y(00 00 00 00 02 00 00 00 21 18 AF 31 98 AE B0 31 90 9E 19 04) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|*STANDARD-OUTPUT*| |CRYPT|::|*KEY*| |CRYPT|::|DECRYPT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CLFSWM-CLIENT|::|SOCK| |COMMON-LISP|::|&OPTIONAL| + |CLFSWM-CLIENT|::|WAIT|) + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|41 48 (DEFUN QUIT-ON-COMMAND (LINE SOCK) ...)-8| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CLFSWM-CLIENT|::|QUIT-ON-COMMAND| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CLFSWM-CLIENT|::|QUIT-ON-COMMAND| + #59Y(00 00 00 00 02 00 00 00 26 03 AE DA DB 38 02 31 C1 1F 26 63 1B 0F + DC 6B 03 AE 6B 04 70 05 33 02 15 38 01 31 9B AE 01 02 38 01 80 82 + 00 1C 67 16 01 38 01 31 97 2E 06 19 03 19 03) + (("quit" "close" "bye") #.#'|COMMON-LISP|::|STRING-EQUAL| + #Y(|CLFSWM-CLIENT|::|QUIT-ON-COMMAND-1| + #20Y(00 00 00 00 02 00 00 00 21 18 AF 31 98 AE B0 31 90 9E 19 04) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|*STANDARD-OUTPUT*| |CRYPT|::|*KEY*| |CRYPT|::|DECRYPT| + |CLFSWM-CLIENT|::|UQUIT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CLFSWM-CLIENT|::|LINE| |CLFSWM-CLIENT|::|SOCK|) |COMMON-LISP|::|NIL| + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|51 61 (DEFUN PARSE-ARGS (SOCK ARGS) ...)-9| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CLFSWM-CLIENT|::|PARSE-ARGS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CLFSWM-CLIENT|::|PARSE-ARGS| + #79Y(00 00 00 00 02 00 00 00 26 03 AD DA 38 04 8C 35 3B AD 38 05 31 89 + 42 02 38 02 72 8F AE AD 31 90 AC 81 90 00 DB 6B 02 AE 33 02 15 B1 + DD AE 6B 04 70 05 2D 03 06 B1 31 9B B1 64 30 07 AC B2 30 08 B1 B1 + AF 38 01 72 60 29 02 08 FF BE 00 19 03) + ("" + #Y(|CLFSWM-CLIENT|::|PARSE-ARGS-1| + #23Y(00 00 00 00 02 00 00 00 21 18 AE B0 31 90 DA B0 38 02 31 95 9E + 19 04) + ("\n + ") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|*STANDARD-OUTPUT*| + #Y(|CLFSWM-CLIENT|::|PARSE-ARGS-2| + #20Y(00 00 00 00 02 00 00 00 21 18 AE B0 31 90 AF 31 97 9E 19 04) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |CRYPT|::|*KEY*| |CRYPT|::|CRYPT| |COMMON-LISP|::|FORMAT| + |CLFSWM-CLIENT|::|PRINT-OUTPUT| |CLFSWM-CLIENT|::|QUIT-ON-COMMAND|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CLFSWM-CLIENT|::|SOCK| |CLFSWM-CLIENT|::|ARGS|) |COMMON-LISP|::|NIL| + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|64 80 (DEFUN START-CLIENT (&OPTIONAL # #) ...)-10| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CLFSWM-CLIENT|::|START-CLIENT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CLFSWM-CLIENT|::|START-CLIENT| + #144Y(00 00 00 00 00 00 02 00 26 0C 3B 02 02 C5 FA 3B 01 03 0E 01 F9 2E + 02 AE AE 70 03 DE AD 01 02 38 01 71 82 6B 05 70 06 70 07 E2 AD 6B + 05 33 02 26 0F 05 38 02 72 8F 6B 05 6B 05 6F 09 AD AF 31 90 AC AF + 31 90 16 02 AC 81 90 00 6B 05 70 0A AE 38 02 31 96 AD 31 9B AD 64 + 30 0B 2E 0C 14 63 1B 09 87 01 00 AF AD 30 0D 83 01 AD 8D 9F 73 16 + 02 AD 2F 0B 38 01 8D 86 78 38 04 71 82 AC 6B 05 70 0A AF 38 02 31 + 96 AE 31 9B AC AF 30 0E 16 01 1B 5F) + (#1="127.0.0.1" |CLFSWM-CLIENT|::|*SERVER-PORT*| |CRYPT|::|LOAD-NEW-KEY| + |PORT|::|OPEN-SOCKET| (#\Newline #\Space) |CRYPT|::|*KEY*| + |CRYPT|::|DECRYPT| |COMMON-LISP|::|STRING-TRIM| |COMMON-LISP|::|STRING| + |MD5|::|MD5| |CRYPT|::|CRYPT| |CLFSWM-CLIENT|::|PRINT-OUTPUT| + |CLFSWM-CLIENT|::|ARGS| |CLFSWM-CLIENT|::|PARSE-ARGS| + |CLFSWM-CLIENT|::|QUIT-ON-COMMAND|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&OPTIONAL| (|CLFSWM-CLIENT|::|URL| #1#) + (|CLFSWM-CLIENT|::|PORT| |CLFSWM-CLIENT|::|*SERVER-PORT*|)) + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) Added: clfswm/contrib/server/clfswm-client.lib ============================================================================== --- (empty file) +++ clfswm/contrib/server/clfswm-client.lib Thu Aug 12 17:30:52 2010 @@ -0,0 +1,30 @@ +#0Y_ #0Y |CHARSET|::|UTF-8| +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "COMMON-LISP-USER")) +(|SYSTEM|::|%IN-PACKAGE| "CLFSWM-CLIENT" :|NICKNAMES| '|COMMON-LISP|::|NIL| + :|USE| '|COMMON-LISP|::|NIL| :|CASE-SENSITIVE| |COMMON-LISP|::|NIL| + :|CASE-INVERTED| |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|USE-PACKAGE| '("COMMON-LISP" "CRYPT") "CLFSWM-CLIENT") +(|COMMON-LISP|::|FIND-PACKAGE| "CLFSWM-CLIENT") +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "CLFSWM-CLIENT")) +(|SYSTEM|::|C-DEFUN| '|CLFSWM-CLIENT|::|ARGS| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|)) +(|SYSTEM|::|C-DEFUN| '|CLFSWM-CLIENT|::|UQUIT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|SPECIAL| |CLFSWM-CLIENT|::|*SERVER-PORT*|)) +(|SYSTEM|::|C-DEFUN| '|CLFSWM-CLIENT|::|PRINT-OUTPUT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|CLFSWM-CLIENT|::|SOCK| |COMMON-LISP|::|&OPTIONAL| + |CLFSWM-CLIENT|::|WAIT|))) +(|SYSTEM|::|C-DEFUN| '|CLFSWM-CLIENT|::|QUIT-ON-COMMAND| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|CLFSWM-CLIENT|::|LINE| |CLFSWM-CLIENT|::|SOCK|))) +(|SYSTEM|::|C-DEFUN| '|CLFSWM-CLIENT|::|PARSE-ARGS| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|CLFSWM-CLIENT|::|SOCK| |CLFSWM-CLIENT|::|ARGS|))) +(|SYSTEM|::|C-DEFUN| '|CLFSWM-CLIENT|::|START-CLIENT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&OPTIONAL| (|CLFSWM-CLIENT|::|URL| "127.0.0.1") + (|CLFSWM-CLIENT|::|PORT| |CLFSWM-CLIENT|::|*SERVER-PORT*|)))) Added: clfswm/contrib/server/clfswm-client.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/clfswm-client.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,81 @@ +(in-package :common-lisp-user) + +(defpackage :clfswm-client + (:use :common-lisp :crypt)) + +(in-package :clfswm-client) + +(defun args () + #+sbcl (cdr sb-ext:*posix-argv*) + #+(or clozure ccl) (cddddr (ccl::command-line-arguments)) + #+gcl (cdr si:*command-args*) + #+ecl (loop for i from 1 below (si:argc) collect (si:argv i)) + #+cmu (cdddr extensions:*command-line-strings*) + #+allegro (cdr (sys:command-line-arguments)) + #+lispworks (cdr sys:*line-arguments-list*) + #+clisp ext:*args* + #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) + (error "get-command-line-arguments not supported for your implementation")) + +(defun uquit () + #+(or clisp cmu) (ext:quit) + #+sbcl (sb-ext:quit) + #+ecl (si:quit) + #+gcl (lisp:quit) + #+lispworks (lw:quit) + #+(or allegro-cl allegro-cl-trial) (excl:exit) + #+ccl (ccl:quit)) + + + +(defparameter *server-port* 33333) + +(defun print-output (sock &optional wait) + (when (or wait (ignore-errors (listen sock))) + (let ((line (ignore-errors (string-trim '(#\newline) (read-line sock nil nil))))) + (when line + (format t "~&~A" (decrypt line *key*)) + (force-output))))) + + +(defun quit-on-command (line sock) + (when (member line '("quit" "close" "bye") :test #'string-equal) + (loop for line = (read-line sock nil nil) + while line + do (format t "~&~A" (decrypt line *key*)) + (force-output)) + (terpri) + (uquit))) + + +(defun parse-args (sock args) + (unless (string= args "") + (multiple-value-bind (form pos) + (read-from-string args) + (let ((str (format nil "~A" form))) + (format t "~A~% " str) + (format sock "~A~%" (crypt str *key*)) + (force-output sock) + (print-output sock t) + (quit-on-command str sock) + (parse-args sock (subseq args pos)))))) + + +(defun start-client (&optional (url "127.0.0.1") (port *server-port*)) + (load-new-key) + (let* ((sock (port:open-socket url port)) + (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*)))) + (setf *key* (concatenate 'string key *key*)) + (write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock) + (force-output sock) + (print-output sock t) + (dolist (a (args)) + (parse-args sock a)) + (loop + (print-output sock) + (when (listen) + (let ((line (read-line))) + (write-line (crypt line *key*) sock) + (force-output sock) + (quit-on-command line sock)))))) + Added: clfswm/contrib/server/configure ============================================================================== --- (empty file) +++ clfswm/contrib/server/configure Thu Aug 12 17:30:52 2010 @@ -0,0 +1,129 @@ +#! /bin/sh + +PROJECT_NAME=clfswm-client +CONFIGURE_VERSION=0.1 + + +usage () { + echo "'configure' configures $PROJECT_NAME to adapt to many kinds of systems. + +Usage: ./configure [OPTION]... [VAR=VALUE]... + +Please, be sure to edit the file key.lisp to change the encryption key. And +protect this file from unwanted eyes. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + -V, --version display version information and exit + --with-lisp=LISP use a particular Lisp implementation [ask] + --with-lisp-eval-opt=OPT use a particular Lisp eval command line option + --with-lisp-load-opt=OPT use a particular Lisp load command line option + --with-lisp-ext=OPT use a particular Lisp extension filename + --with-lisp-core=CORE use a particular Lisp core (initial memory image) + --prefix=PREFIX install architecture-independent files in PREFIX + [/usr/local] + +By default, 'make install' will install all the files in +'/usr/local/bin', '/usr/local/lib' etc. You can specify +an installation prefix other than '/usr/local' using '--prefix', +for instance '--prefix=$HOME'." + exit 0 +} + + +version () { + echo "Configure version: $CONFIGURE_VERSION" + exit 0 +} + + + +TEMP=`getopt -o hV: --long help,version,srcdir:,with-lisp:,with-lisp-eval-opt:,with-lisp-load-opt:,with-lisp-ext:,with-lisp-core:,prefix: -- "$@"` +PREFIX=/usr/local + +if [ $? != 0 ] ; then echo "Terminating..." >&2 ; exit 1 ; fi + +eval set -- "$TEMP" + +while true ; do + case "$1" in + -h|--help) usage ; shift ;; + -V|--version) version ; shift ;; + --srcdir) SRCDIR=$2 ; shift 2 ;; + --with-lisp) LISP=$2 ; shift 2 ;; + --with-lisp-eval-opt) EVAL_OPT=$2 ; shift 2 ;; + --with-lisp-load-opt) LOAD_OPT=$2 ; shift 2 ;; + --with-lisp-ext) EXT=$2 ; shift 2 ;; + --with-lisp-core) CORE=$2 ; shift 2 ;; + --prefix) PREFIX=$2 ; shift 2 ;; + --key-perms) KEY_PERMS=$2 ; shift 2 ;; + --) shift ; break ;; + *) echo "Internal error!" ; exit 1 ;; + esac +done + +DESTDIR=$PREFIX + + +if [ "x$LISP" = "x" ]; then + echo "Please, choose a Lisp implementation in: +1) SBCL 2) CMUCL 3) CLISP 4) ECL 5) CCL 6) Other" + read REP_LISP + case $REP_LISP in + 1) LISP=sbcl ;; + 2) LISP=cmucl ;; + 3) LISP=clisp ;; + 4) LISP=ecl ;; + 5) LISP=ccl ;; + 6) echo -n "Please, enter your Lisp implementation: " + read LISP ;; + *) echo "Error"; exit -1 ;; + esac +fi + +EXTRA_OPT="" + +case $LISP in + clisp) LISP=$(which clisp) + EVAL_OPT="-x -q" + LOAD_OPT="" + EXT=fas ;; + sbcl) LISP=$(which sbcl) + EVAL_OPT="--eval" + LOAD_OPT="--load" + EXT=fasl ;; + cmucl) LISP=$(which cmucl) + EVAL_OPT="-eval" + LOAD_OPT="-load" + EXT=x86f ;; + ecl) LISP=$(which ecl) + EVAL_OPT="-eval" + LOAD_OPT="-load" + EXT=fas ;; + ccl) LISP=$(which ccl) + EVAL_OPT="-e" + LOAD_OPT="-l" + EXT=lx32fsl + EXTRA_OPT="--" ;; +esac + +echo "Configuration:" +echo SRCDIR = $SRCDIR +echo PREFIX = $PREFIX +echo "LISP=$LISP EVAL_OPT=$EVAL_OPT LOAD_OPT=$LOAD_OPT EXT=$EXT CORE=$CORE EXTRA_OPT=$EXTRA_OPT" + +sed -e "s#+PROJECT_NAME+#$PROJECT_NAME#g" \ + -e "s#+DESTDIR+#$DESTDIR#g" \ + -e "s#+LISP+#$LISP#g" \ + -e "s#+EVAL_OPT+#$EVAL_OPT#g" \ + -e "s#+LOAD_OPT+#$LOAD_OPT#g" \ + -e "s#+EXT+#$EXT#g" \ + -e "s#+CORE+#$CORE#g" \ + -e "s#+EXTRA_OPT+#$EXTRA_OPT#g" \ + Makefile.template > Makefile + +echo "" +echo "Type 'make' to build $PROJECT_NAME" +echo "" Added: clfswm/contrib/server/crypt.fas ============================================================================== --- (empty file) +++ clfswm/contrib/server/crypt.fas Thu Aug 12 17:30:52 2010 @@ -0,0 +1,210 @@ +(|SYSTEM|::|VERSION| '(20080430.)) +#0Y_ #0Y |CHARSET|::|UTF-8| +#Y(#:|1 1 (IN-PACKAGE :COMMON-LISP-USER)-1| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("COMMON-LISP-USER" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 7 (DEFPACKAGE :CRYPT (:USE :COMMON-LISP) ...)-2-1| + #18Y(00 00 00 00 00 00 00 00 20 01 DA 01 04 31 F0 3E 19 01) ("CRYPT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 7 (DEFPACKAGE :CRYPT (:USE :COMMON-LISP) ...)-2-2| + #17Y(00 00 00 00 00 00 00 00 20 01 DA DB 31 EC 3E 19 01) + (("COMMON-LISP") "CRYPT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 7 (DEFPACKAGE :CRYPT (:USE :COMMON-LISP) ...)-2-3| + #19Y(00 00 00 00 00 00 00 00 20 01 DA DB 63 2D 03 02 3E 19 01) + ((#1="CRYPT" "DECRYPT" "GENERATE-KEY") #1# |SYSTEM|::|INTERN-EXPORT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 7 (DEFPACKAGE :CRYPT (:USE :COMMON-LISP) ...)-2-4| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 D9 19 01) ("CRYPT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) +#Y(#:|9 9 (IN-PACKAGE :CRYPT)-3| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("CRYPT" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|11 18 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (DEFUN MKSTR # ...) ...)-4-1| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C 3E 19 01) + (|CRYPT|::|MKSTR| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|MKSTR| + #51Y(03 00 01 00 00 00 00 00 27 16 DA 38 01 72 8F 53 17 B0 63 1B 09 87 + 01 00 14 B1 31 90 83 01 AD 8D 9F 73 16 02 AE 32 90 54 67 00 00 00 + 38 01 32 97 55 19 03) + (|COMMON-LISP|::|CHARACTER|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&REST| |CRYPT|::|ARGS|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|11 18 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (DEFUN MKSTR # ...) ...)-4-2| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|SYMB| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|SYMB| + #22Y(00 00 00 00 00 00 00 00 27 16 99 00 9F 77 00 38 01 31 E1 3F 19 02) + (|CRYPT|::|MKSTR|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&REST| |CRYPT|::|ARGS|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|22 55 (DEFMACRO CIRC-LOOP (BINDING &BODY BODY) ...)-5| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|CRYPT|::|CIRC-LOOP| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|CIRC-LOOP| + #72Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 64 2D 04 01 1D 30 9F 5C 78 + A0 5C 79 63 6D 03 01 63 6D 04 01 63 6D 05 01 38 01 72 AA E0 AD B3 + CC 74 E2 AF B5 A5 74 B5 A4 74 E3 B7 A5 74 A8 5D 7A 7B 04 61 03 19 + 09 AE 2F 02 19 03) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + #Y(|CRYPT|::|CIRC-LOOP-DO-BODY| + #83Y(00 00 00 00 02 00 00 00 26 03 94 01 C6 74 AF DC DD 6E 03 04 DF + 94 04 C6 74 7B 02 7B 03 E0 95 03 01 02 1B 23 87 02 01 14 C6 74 + B4 E1 B2 6E 03 04 E2 DF B1 C6 74 7B 02 B7 E3 B5 6E 03 04 7B 03 + 7B 03 84 00 85 03 83 02 AE 8D 9F 59 AC 31 B1 16 04 5D 19 03) + (|COMMON-LISP|::|NIL| + #1=#Y(|CRYPT|::|CIRC-LOOP-LOOP-VAR-NAME| + #17Y(00 00 00 00 01 00 00 00 26 02 DA 94 02 30 01 19 02) + ("LOOP-VAR-" |CRYPT|::|SYMB|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|L|) |COMMON-LISP|::|NIL| 1) + "-" 0. |CRYPT|::|SYMB| |COMMON-LISP|::|CDR| 1. "-" + |COMMON-LISP|::|OR| "-") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|PREFIX| |COMMON-LISP|::|LIST|) |COMMON-LISP|::|NIL| 1) + #Y(|CRYPT|::|CIRC-LOOP-STOP-BODY| + #21Y(00 00 00 00 01 00 00 00 26 02 DB 94 02 C7 74 7B 02 61 01 19 02) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NULL| #1#) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|LIST|) |COMMON-LISP|::|NIL| 1) + #Y(|CRYPT|::|CIRC-LOOP-SYMBOL-BODY| + #40Y(00 00 00 00 01 00 00 00 26 02 AD 01 02 1B 10 87 02 01 78 DB AF + C7 74 7B 02 7B 02 84 00 83 02 AE 8D 9F 6C AC 31 B1 19 05) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|CAR| #1#) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|LIST|) |COMMON-LISP|::|NIL| 1) + |COMMON-LISP|::|LET| + #Y(|CRYPT|::|CIRC-LOOP-LET-BODY| + #49Y(00 00 00 00 02 00 00 00 26 03 DA AE 01 02 1B 18 87 02 01 B2 DB + B1 6E 03 02 DD A0 5C 78 C9 5D 7A 7B 02 84 00 85 03 83 02 AE 8D + 9F 64 AC 31 B1 19 07) + (0. "-" |CRYPT|::|SYMB| |COMMON-LISP|::|COERCE| + ('|COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|PREFIX| |COMMON-LISP|::|LIST|) |COMMON-LISP|::|NIL| 1) + |COMMON-LISP|::|DO| |COMMON-LISP|::|SYMBOL-MACROLET|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) + "Loop circularly over some sequences.\n +binding is a list of (variable sequence).\n +The loop is the same size of the first sequence.\n +Each variable binding element is bound to each character in the\n +sequence in the second element.\n +See 'test-circ-loop for some usage examples." + 1) + (|CRYPT|::|BINDING| |COMMON-LISP|::|&BODY| |CRYPT|::|BODY|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|57 68 (DEFUN TEST-CIRC-LOOP NIL ...)-6| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|TEST-CIRC-LOOP| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|TEST-CIRC-LOOP| + #146Y(00 00 00 00 00 00 00 00 26 01 DA 38 01 31 8E DB DC 72 3B DD DC 72 + 3B DE DC 72 3B DF DC 72 3B AF AF AF AF 93 03 2B 94 03 94 03 94 03 + 94 03 7B 04 38 01 31 8E 95 03 A0 5C 1C 01 A4 14 A0 5C 1C 01 A4 14 + A0 5C 1C 01 A4 FB 6A 03 6A 03 6A 03 92 03 55 16 08 E0 38 01 31 8E + 38 01 31 97 E1 DC 72 3B E2 DC 72 3B E3 DC 72 3B AE AE AE 93 02 21 + E4 6B 0B 94 04 94 04 94 04 33 04 15 95 02 9F 5C 1C 01 A2 14 9F 5C + 1C 01 A2 FA 6A 02 6A 02 92 02 5F 00 19 07) + (|CRYPT|::|FIRST-TEST| "Ceci est un test. ??????^# 1234567890" + |COMMON-LISP|::|LIST| "azerty" "test" "123" |CRYPT|::|SECOND-TEST| + #(1. 2. 3. 4. 5. 6. 7. 8. 9. 10.) (1. 2. 3.) "abcd" + #Y(|CRYPT|::|TEST-CIRC-LOOP-1| + #43Y(00 00 00 00 04 00 00 00 21 1A DA B2 31 94 B0 B2 31 90 DB B2 31 + 94 AF B2 31 90 DB B2 31 94 AE B2 31 90 DC B2 38 02 31 95 9E 19 + 06) + (#\( #\Space ") ") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|*STANDARD-OUTPUT*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|72 76 (DEFUN CRYPT-TO-LIST (MSG &OPTIONAL #) ...)-7| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|CRYPT-TO-LIST| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|CRYPT-TO-LIST| + #72Y(00 00 00 00 01 00 01 00 26 08 3B 01 02 C5 F9 AE 72 62 AC AF 72 D2 + 32 AC 1F 2C DB AD B0 73 01 3A 63 1B 18 B2 AF B3 73 02 39 96 04 B4 + 73 02 39 72 60 38 02 DC 64 71 8A 84 00 85 02 AE AE 91 01 34 62 AC + 31 B1 19 07 19 04) + (4. 0. 16.) (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|MSG| |COMMON-LISP|::|&OPTIONAL| (|CRYPT|::|SIZE| 4.)) + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|80 83 (DEFUN CRYPT (MSG KEY) ...)-8| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|CRYPT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|CRYPT| + #76Y(03 00 01 00 02 00 00 00 26 03 DA 38 01 72 8F 53 30 B1 DB 72 3B B1 + DB 72 3B AD AD 93 01 1D B2 DC 94 03 71 28 94 03 71 28 73 02 3F 2D + 03 03 95 01 9E 5C 1C 01 A0 F9 6A 01 92 01 63 16 04 AE 32 90 54 67 + 00 00 00 38 01 32 97 55 19 04) + (|COMMON-LISP|::|CHARACTER| |COMMON-LISP|::|LIST| + #Y(|CRYPT|::|CRYPT-1| + #24Y(00 00 00 00 02 00 00 00 21 18 AF 01 02 DA DB 01 02 B5 2D 08 02 + 9E 19 04) + (4. #\0 |SYSTEM|::|DO-FORMAT-HEXADECIMAL|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|FORMAT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|MSG| |CRYPT|::|KEY|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|86 89 (DEFUN DECRYPT (MSG KEY) ...)-9| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|DECRYPT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|DECRYPT| + #77Y(03 00 01 00 02 00 00 00 26 03 DA 38 01 72 8F 53 31 B1 DB 70 02 DD + 72 3B B1 DD 72 3B AD AD 93 01 1B 94 01 94 01 71 28 73 02 3F 71 29 + B3 31 90 95 01 9E 5C 1C 01 A0 F9 6A 01 92 01 65 16 04 AE 32 90 54 + 67 00 00 00 38 01 32 97 55 19 04) + (|COMMON-LISP|::|CHARACTER| 4. |CRYPT|::|CRYPT-TO-LIST| + |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|MSG| |CRYPT|::|KEY|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|91 96 (DEFUN TEST NIL ...)-10| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|TEST| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|TEST| + #50Y(00 00 00 00 00 00 00 00 26 01 38 02 72 8F AC 01 02 DA 2D 04 01 DC + AD 38 02 31 95 AC 81 90 00 AC DD 70 04 AC DD 70 05 E0 6B 07 B0 B0 + B0 33 04 15 19 04) + (#\d |SYSTEM|::|DO-FORMAT-CHARACTER| + " Ceci est un test. ??????^# 1234567890" + "11a3e229084349bc25d97e29393ced1d" |CRYPT|::|CRYPT| |CRYPT|::|DECRYPT| + #Y(|CRYPT|::|TEST-1| + #46Y(00 00 00 00 04 00 00 00 21 1A DA B2 38 02 31 95 B0 B2 31 90 DB + B2 38 02 31 95 AF B2 31 90 DC B2 38 02 31 95 AE B2 31 90 B1 31 + 97 9E 19 06) + ("msg: " + "\n +Crypt: " + "\n +Decrypt: ") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|*STANDARD-OUTPUT*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|101 112 (LET* (# #) (DEFUN GENERATE-KEY # ...))-11| + #114Y(03 00 01 00 00 00 00 00 20 01 00 2B 02 DA 38 01 72 8F 53 3D DB 1B 16 + AC DD 73 02 37 71 29 B0 31 90 AC DE 73 02 37 71 29 B0 31 90 85 00 AC + DC 91 01 34 64 16 01 DB 1B 0C AC E0 73 02 37 71 29 B0 31 90 85 00 AC + DF 91 01 34 6E 16 01 AE 32 90 3F 54 67 00 00 00 38 01 32 97 55 16 01 + 0B 00 00 14 32 62 0B 00 01 E1 2F 08 E1 AD 6D 09 01 32 9C CC 19 02) + (|COMMON-LISP|::|CHARACTER| 0. 26. 97. 65. 10. 48. |CRYPT|::|GENERATE-KEY| + |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|GENERATE-KEY| + #84Y(03 00 01 00 00 00 02 00 26 0C 3B 02 02 C6 FA 3B 01 02 C7 F9 AD AF + 73 01 38 38 01 72 F7 AF 73 02 37 DD 38 01 72 8F 53 21 DE 1B 12 69 + 00 01 69 00 02 38 01 72 F7 73 01 01 B0 31 90 85 00 AC B1 91 01 34 + 68 16 01 AE 32 90 54 67 00 00 00 38 01 32 97 55 19 05) + (|COMMON-LISP|::|NIL| 10. 30. |COMMON-LISP|::|CHARACTER| 0.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&OPTIONAL| (|CRYPT|::|MIN-SIZE| 10.) + (|CRYPT|::|MAX-SIZE| 30.)) + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) Added: clfswm/contrib/server/crypt.lib ============================================================================== --- (empty file) +++ clfswm/contrib/server/crypt.lib Thu Aug 12 17:30:52 2010 @@ -0,0 +1,114 @@ +#0Y_ #0Y |CHARSET|::|UTF-8| +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "COMMON-LISP-USER")) +(|SYSTEM|::|%IN-PACKAGE| "CRYPT" :|NICKNAMES| '|COMMON-LISP|::|NIL| :|USE| + '|COMMON-LISP|::|NIL| :|CASE-SENSITIVE| |COMMON-LISP|::|NIL| :|CASE-INVERTED| + |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|USE-PACKAGE| '("COMMON-LISP") "CRYPT") +(|SYSTEM|::|INTERN-EXPORT| '(#1="CRYPT" "DECRYPT" "GENERATE-KEY") #1# + |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|FIND-PACKAGE| "CRYPT") +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "CRYPT")) +(|COMMON-LISP|::|DEFUN| |CRYPT|::|MKSTR| + (|COMMON-LISP|::|&REST| |CRYPT|::|ARGS|) + (|COMMON-LISP|::|WITH-OUTPUT-TO-STRING| (|CRYPT|::|S|) + (|COMMON-LISP|::|DOLIST| (|CRYPT|::|A| |CRYPT|::|ARGS|) + (|COMMON-LISP|::|PRINC| |CRYPT|::|A| |CRYPT|::|S|)))) +(|COMMON-LISP|::|DEFUN| |CRYPT|::|SYMB| + (|COMMON-LISP|::|&REST| |CRYPT|::|ARGS|) + (|COMMON-LISP|::|VALUES| + (|COMMON-LISP|::|INTERN| + (|COMMON-LISP|::|APPLY| #'|CRYPT|::|MKSTR| |CRYPT|::|ARGS|)))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|MKSTR| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&REST| |CRYPT|::|ARGS|))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|SYMB| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&REST| |CRYPT|::|ARGS|))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|CRYPT|::|CIRC-LOOP|) +(|SYSTEM|::|%PUTD| '|CRYPT|::|CIRC-LOOP| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |CRYPT|::|CIRC-LOOP| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + "Loop circularly over some sequences.\n +binding is a list of (variable sequence).\n +The loop is the same size of the first sequence.\n +Each variable binding element is bound to each character in the\n +sequence in the second element.\n +See 'test-circ-loop for some usage examples." + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|T|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|CRYPT|::|BINDING| + (|COMMON-LISP|::|CADR| . #1=(|SYSTEM|::||))) + (|CRYPT|::|BODY| (|COMMON-LISP|::|CDDR| . #1#))) + (|COMMON-LISP|::|BLOCK| |CRYPT|::|CIRC-LOOP| + (|COMMON-LISP|::|LABELS| + ((|CRYPT|::|LET-BODY| (|CRYPT|::|PREFIX| |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|LOOP| |CRYPT|::|FOR| |CRYPT|::|I| |CRYPT|::|FROM| 0. + |CRYPT|::|FOR| |CRYPT|::|L| |CRYPT|::|IN| |COMMON-LISP|::|LIST| + |CRYPT|::|COLLECT| + `(,(|CRYPT|::|SYMB| |CRYPT|::|PREFIX| "-" |CRYPT|::|I|) + (|COMMON-LISP|::|COERCE| ,(|COMMON-LISP|::|SECOND| |CRYPT|::|L|) + '|COMMON-LISP|::|LIST|)))) + (|CRYPT|::|LOOP-VAR-NAME| (|CRYPT|::|L|) + (|CRYPT|::|SYMB| "LOOP-VAR-" (|COMMON-LISP|::|FIRST| |CRYPT|::|L|))) + (|CRYPT|::|DO-BODY| (|CRYPT|::|PREFIX| |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|CONS| + (|COMMON-LISP|::|LIST| + (|CRYPT|::|LOOP-VAR-NAME| + (|COMMON-LISP|::|FIRST| |COMMON-LISP|::|LIST|)) + (|CRYPT|::|SYMB| |CRYPT|::|PREFIX| "-" 0.) + `(|COMMON-LISP|::|CDR| + ,(|CRYPT|::|LOOP-VAR-NAME| + (|COMMON-LISP|::|FIRST| |COMMON-LISP|::|LIST|)))) + (|COMMON-LISP|::|LOOP| |CRYPT|::|FOR| |CRYPT|::|I| |CRYPT|::|FROM| + 1. |CRYPT|::|FOR| |CRYPT|::|L| |CRYPT|::|IN| + (|COMMON-LISP|::|CDR| |COMMON-LISP|::|LIST|) |CRYPT|::|COLLECT| + (|COMMON-LISP|::|LIST| (|CRYPT|::|LOOP-VAR-NAME| |CRYPT|::|L|) + (|CRYPT|::|SYMB| |CRYPT|::|PREFIX| "-" |CRYPT|::|I|) + `(|COMMON-LISP|::|OR| + (|COMMON-LISP|::|CDR| ,(|CRYPT|::|LOOP-VAR-NAME| |CRYPT|::|L|)) + ,(|CRYPT|::|SYMB| |CRYPT|::|PREFIX| "-" |CRYPT|::|I|)))))) + (|CRYPT|::|STOP-BODY| (|COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|LIST| + `(|COMMON-LISP|::|NULL| + ,(|CRYPT|::|LOOP-VAR-NAME| + (|COMMON-LISP|::|FIRST| |COMMON-LISP|::|LIST|))))) + (|CRYPT|::|SYMBOL-BODY| (|COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|LOOP| |CRYPT|::|FOR| |CRYPT|::|L| |CRYPT|::|IN| + |COMMON-LISP|::|LIST| |CRYPT|::|COLLECT| + `(,(|COMMON-LISP|::|FIRST| |CRYPT|::|L|) + (|COMMON-LISP|::|CAR| + ,(|CRYPT|::|LOOP-VAR-NAME| |CRYPT|::|L|)))))) + (|COMMON-LISP|::|LET| ((|CRYPT|::|PREFIX| (|COMMON-LISP|::|GENSYM|))) + `(|COMMON-LISP|::|LET| + (,@(|CRYPT|::|LET-BODY| |CRYPT|::|PREFIX| |CRYPT|::|BINDING|)) + (|COMMON-LISP|::|DO| + ,(|CRYPT|::|DO-BODY| |CRYPT|::|PREFIX| |CRYPT|::|BINDING|) + ,(|CRYPT|::|STOP-BODY| |CRYPT|::|BINDING|) + (|COMMON-LISP|::|SYMBOL-MACROLET| + ,(|CRYPT|::|SYMBOL-BODY| |CRYPT|::|BINDING|) + ,@|CRYPT|::|BODY|)))))))))) + '(|CRYPT|::|BINDING| |COMMON-LISP|::|&BODY| |CRYPT|::|BODY|))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|TEST-CIRC-LOOP| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|)) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|CRYPT-TO-LIST| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|CRYPT|::|MSG| |COMMON-LISP|::|&OPTIONAL| (|CRYPT|::|SIZE| 4.)))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|CRYPT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|CRYPT|::|MSG| |CRYPT|::|KEY|))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|DECRYPT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|CRYPT|::|MSG| |CRYPT|::|KEY|))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|TEST| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|)) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|GENERATE-KEY| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&OPTIONAL| (|CRYPT|::|MIN-SIZE| 10.) + (|CRYPT|::|MAX-SIZE| 30.)))) Added: clfswm/contrib/server/crypt.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/crypt.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,112 @@ +(in-package :common-lisp-user) + +(defpackage :crypt + (:use :common-lisp) + (:export :crypt + :decrypt + :generate-key)) + +(in-package :crypt) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (a args) + (princ a s)))) + + (defun symb (&rest args) + (values (intern (apply #'mkstr args))))) + + + +(defmacro circ-loop (binding &body body) + "Loop circularly over some sequences. +binding is a list of (variable sequence). +The loop is the same size of the first sequence. +Each variable binding element is bound to each character in the +sequence in the second element. +See 'test-circ-loop for some usage examples." + (labels ((let-body (prefix list) + (loop for i from 0 + for l in list + collect `(,(symb prefix "-" i) (coerce ,(second l) 'list)))) + (loop-var-name (l) + (symb "LOOP-VAR-" (first l))) + (do-body (prefix list) + (cons (list (loop-var-name (first list)) + (symb prefix "-" 0) + `(cdr ,(loop-var-name (first list)))) + (loop for i from 1 + for l in (cdr list) + collect (list (loop-var-name l) + (symb prefix "-" i) + `(or (cdr ,(loop-var-name l)) + ,(symb prefix "-" i)))))) + (stop-body (list) + (list `(null ,(loop-var-name (first list))))) + (symbol-body (list) + (loop for l in list + collect `(,(first l) (car ,(loop-var-name l)))))) + (let ((prefix (gensym))) + `(let (,@(let-body prefix binding)) + (do ,(do-body prefix binding) + ,(stop-body binding) + (symbol-macrolet ,(symbol-body binding) + , at body)))))) + +(defun test-circ-loop () + (print 'first-test) + (circ-loop ((m "Ceci est un test. ???^# 1234567890") + (k "azerty") + (p "test") + (o "123")) + (print (list m k p o))) + (print 'second-test) (terpri) + (circ-loop ((a #(1 2 3 4 5 6 7 8 9 10)) + (b '(1 2 3)) + (c "abcd")) + (format t "(~A ~A ~A) " a b c))) + + + +(defun crypt-to-list (msg &optional (size 4)) + (let ((len (length msg))) + (when (zerop (mod len size)) + (loop for i from 0 below (/ len size) + collect (parse-integer (subseq msg (* i size) (* (1+ i) size)) :radix 16 :junk-allowed t))))) + + + +(defun crypt (msg key) + (with-output-to-string (str) + (circ-loop ((m msg) (k key)) + (format str "~4,'0X" (logxor (char-code m) (char-code k)))))) + + +(defun decrypt (msg key) + (with-output-to-string (str) + (circ-loop ((m (crypt-to-list msg 4)) (k key)) + (princ (code-char (logxor m (char-code k))) str)))) + +(defun test () + (let* ((key "11a3e229084349bc25d97e29393ced1d") + (msg (format nil "~C Ceci est un test. ???^# 1234567890" (code-char 100))) + (crypt (crypt msg key)) + (decrypt (decrypt crypt key))) + (format t "msg: ~A~%Crypt: ~A~%Decrypt: ~A~%" msg crypt decrypt))) + + + + +(let* ((dic (with-output-to-string (str) + (dotimes (i 26) + (princ (code-char (+ i (char-code #\a))) str) + (princ (code-char (+ i (char-code #\A))) str)) + (dotimes (i 10) + (princ (code-char (+ i (char-code #\0))) str)))) + (dic-size (length dic))) + (defun generate-key (&optional (min-size 10) (max-size 30)) + (let ((length (+ (random (- max-size min-size)) min-size))) + (with-output-to-string (str) + (dotimes (i length) + (princ (aref dic (random dic-size)) str)))))) Added: clfswm/contrib/server/key.fas ============================================================================== --- (empty file) +++ clfswm/contrib/server/key.fas Thu Aug 12 17:30:52 2010 @@ -0,0 +1,101 @@ +(|SYSTEM|::|VERSION| '(20080430.)) +#0Y_ #0Y |CHARSET|::|UTF-8| +#Y(#:|1 1 (IN-PACKAGE :CRYPT)-1| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("CRYPT" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|3 5 (EXPORT '(LOAD-NEW-KEY SAVE-NEW-KEY *KEY*))-2| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 38 01 31 E6 19 01) + ((|CRYPT|::|LOAD-NEW-KEY| |CRYPT|::|SAVE-NEW-KEY| |CRYPT|::|*KEY*|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|7 7 (DEFPARAMETER *KEY-FILENAME* "/tmp/.clfswm-server.key")-3| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB DC 31 5A C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |CRYPT|::|*KEY-FILENAME*|) + |CRYPT|::|*KEY-FILENAME*| "/tmp/.clfswm-server.key") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|9 9 (DEFPARAMETER *KEY* "Automatically changed")-4| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB DC 31 5A C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |CRYPT|::|*KEY*|) |CRYPT|::|*KEY*| + "Automatically changed") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|11 11 (DEFPARAMETER *INITIAL-KEY-PERMS* "0600")-5| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB DC 31 5A C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |CRYPT|::|*INITIAL-KEY-PERMS*|) + |CRYPT|::|*INITIAL-KEY-PERMS*| "0600") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|12 12 (DEFPARAMETER *FINAL-KEY-PERMS* "0400")-6| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB DC 31 5A C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |CRYPT|::|*FINAL-KEY-PERMS*|) + |CRYPT|::|*FINAL-KEY-PERMS*| "0400") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|15 48 (DEFUN USHELL-SH (FORMATTER &REST ARGS) ...)-7| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|USHELL-SH| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|USHELL-SH| + #31Y(00 00 00 00 01 00 00 00 27 17 63 6D 00 01 AC DB DC DD 99 04 63 B5 + A6 77 02 7B 02 36 03 19 04) + (#Y(|CRYPT|::|USHELL-SH-URUN-PROG| + #40Y(00 00 00 00 01 00 00 00 E7 00 02 00 01 00 3D 02 3B 01 02 7E 01 + AF DB DC 7B 02 C8 34 FB 99 04 B1 DF B1 DC B2 A6 9B 05 05) + (|COMMON-LISP|::|NIL| :|ARGS| :|WAIT| + #Y(|CRYPT|::|USHELL-SH-REMOVE-PLIST| + #52Y(00 00 00 00 01 00 00 00 27 17 01 02 1B 14 94 04 83 05 84 01 + 94 04 83 05 84 01 B0 9E 23 70 A1 5C 5C FC B0 B0 32 A0 42 03 + 15 16 02 F8 1C 6C AD B1 31 B0 19 05) + () (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|CRYPT|::|PLIST| |COMMON-LISP|::|&REST| |CRYPT|::|KEYS|) + "Remove the keys from the plist.\n +Useful for re-using the &REST arg after removing some options." + 1) + |EXT|::|RUN-PROGRAM| :|ARGUMENTS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|PROG| |COMMON-LISP|::|&REST| |CRYPT|::|OPTS| + |COMMON-LISP|::|&KEY| |CRYPT|::|ARGS| + (|CRYPT|::|WAIT| |COMMON-LISP|::|T|) + |COMMON-LISP|::|&ALLOW-OTHER-KEYS|) + "Common interface to shell. Does not return anything useful." 1) + "/bin/sh" :|ARGS| "-c" |COMMON-LISP|::|FORMAT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|FORMATTER| |COMMON-LISP|::|&REST| |CRYPT|::|ARGS|) + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|51 62 (DEFUN SAVE-NEW-KEY NIL ...)-8| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|SAVE-NEW-KEY| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|SAVE-NEW-KEY| + #140Y(03 00 01 00 00 00 00 00 26 01 6B 00 8F 08 04 6B 00 32 09 6B 00 DB + 38 05 C7 FB C8 FA 72 0B 53 14 AE DE 30 05 93 02 03 14 2F 06 3E 54 + 05 00 00 00 1D 0E 1B 06 05 00 00 00 1D 06 14 E1 64 2D 03 06 55 16 + 01 E2 6B 09 6B 00 2D 03 0A 2E 0B 0F 0C 6B 00 DB 38 05 C7 FB C8 FA + 72 0B 53 17 AE E7 6B 0C 2D 03 05 93 02 03 14 2F 06 3E 54 05 00 00 + 00 1D 0E 1B 06 05 00 00 00 1D 06 14 E1 64 2D 03 06 55 16 01 E8 6B + 0F 6B 00 2D 03 0A 19 01) + (|CRYPT|::|*KEY-FILENAME*| :|OUTPUT| :|SUPERSEDE| :|CREATE| + #Y(|CRYPT|::|SAVE-NEW-KEY-1| + #19Y(00 00 00 00 01 00 00 00 21 17 DA AF 38 02 31 95 9E 19 03) + ("Nothing useful\n") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|FORMAT| |COMMON-LISP|::|CLOSE| :|ABORT| "chmod ~A ~A" + |CRYPT|::|*INITIAL-KEY-PERMS*| |CRYPT|::|USHELL-SH| + |CRYPT|::|GENERATE-KEY| |CRYPT|::|*KEY*| + #Y(|CRYPT|::|SAVE-NEW-KEY-2| + #20Y(00 00 00 00 02 00 00 00 21 18 AE B0 31 90 AF 31 97 9E 19 04) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + "chmod ~A ~A" |CRYPT|::|*FINAL-KEY-PERMS*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|64 68 (DEFUN LOAD-NEW-KEY NIL ...)-9| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|CRYPT|::|LOAD-NEW-KEY| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|CRYPT|::|LOAD-NEW-KEY| + #76Y(03 00 01 00 00 00 00 00 26 01 6B 00 8E 08 06 E0 6B 00 33 01 1E 6B + 00 DB 38 05 72 0B 53 1F C7 45 AF 01 02 38 01 31 82 0F 03 14 05 00 + 00 02 1D 03 14 2F 04 46 54 05 00 00 00 1D 0E 1B 06 05 00 00 00 1D + 06 14 DF 64 2D 03 04 55 19 02) + (|CRYPT|::|*KEY-FILENAME*| :|INPUT| #.#'|COMMON-LISP|::|VALUES| + |CRYPT|::|*KEY*| |COMMON-LISP|::|CLOSE| :|ABORT| + "Key file ~S not found") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) Added: clfswm/contrib/server/key.lib ============================================================================== --- (empty file) +++ clfswm/contrib/server/key.lib Thu Aug 12 17:30:52 2010 @@ -0,0 +1,16 @@ +#0Y_ #0Y |CHARSET|::|UTF-8| +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "CRYPT")) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|SPECIAL| |CRYPT|::|*KEY-FILENAME*|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|SPECIAL| |CRYPT|::|*KEY*|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|SPECIAL| |CRYPT|::|*INITIAL-KEY-PERMS*|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|SPECIAL| |CRYPT|::|*FINAL-KEY-PERMS*|)) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|USHELL-SH| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|FORMATTER| |COMMON-LISP|::|&REST| |CRYPT|::|ARGS|))) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|SAVE-NEW-KEY| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|)) +(|SYSTEM|::|C-DEFUN| '|CRYPT|::|LOAD-NEW-KEY| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|)) Added: clfswm/contrib/server/key.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/key.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,70 @@ +(in-package :crypt) + +(export '(load-new-key + save-new-key + *key*)) + +(defparameter *key-filename* "/tmp/.clfswm-server.key") + +(defparameter *key* "Automatically changed") + +(defparameter *initial-key-perms* "0600") +(defparameter *final-key-perms* "0400") + + +(defun ushell-sh (formatter &rest args) + (labels ((remove-plist (plist &rest keys) + "Remove the keys from the plist. +Useful for re-using the &REST arg after removing some options." + (do (copy rest) + ((null (setq rest (nth-value 2 (get-properties plist keys)))) + (nreconc copy plist)) + (do () ((eq plist rest)) + (push (pop plist) copy) + (push (pop plist) copy)) + (setq plist (cddr plist)))) + (urun-prog (prog &rest opts &key args (wait t) &allow-other-keys) + "Common interface to shell. Does not return anything useful." + #+gcl (declare (ignore wait)) + (setq opts (remove-plist opts :args :wait)) + #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args) + :wait wait opts) + #+(and clisp lisp=cl) + (apply #'ext:run-program prog :arguments args :wait wait opts) + #+(and clisp (not lisp=cl)) + (if wait + (apply #'lisp:run-program prog :arguments args opts) + (lisp:shell (format nil "~a~{ '~a'~} &" prog args))) + #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts) + #+gcl (apply #'si:run-process prog args) + #+liquid (apply #'lcl:run-program prog args) + #+lispworks (apply #'sys::call-system-showing-output + (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait)) + opts) + #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts) + #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts) + #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl) + (error 'not-implemented :proc (list 'run-prog prog opts)))) + (urun-prog "/bin/sh" :args (list "-c" (apply #'format nil formatter args))))) + + +(defun save-new-key () + (when (probe-file *key-filename*) + (delete-file *key-filename*)) + (with-open-file (stream *key-filename* :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format stream "Nothing useful~%")) + (ushell-sh "chmod ~A ~A" *initial-key-perms* *key-filename*) + (setf *key* (generate-key)) + (with-open-file (stream *key-filename* :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format stream "~A~%" *key*)) + (ushell-sh "chmod ~A ~A" *final-key-perms* *key-filename*)) + +(defun load-new-key () + (if (probe-file *key-filename*) + (with-open-file (stream *key-filename* :direction :input) + (setf *key* (read-line stream nil nil))) + (error "Key file ~S not found" *key-filename*))) + + Added: clfswm/contrib/server/load.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/load.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,59 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: CLFSWM Client +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2005 Philippe Brochard +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; -------------------------------------------------------------------------- + +(defparameter *base-dir* (directory-namestring *load-truename*)) +(export '*base-dir*) + +#+CMU +(setf ext:*gc-verbose* nil) + +#+SBCL +(require :asdf) + +#+SBCL +(require :sb-posix) + +#-ASDF +(let ((asdf-file (make-pathname :host (pathname-host *base-dir*) + :device (pathname-device *base-dir*) + :directory (pathname-directory *base-dir*) + :name "asdf" :type "lisp"))) + (if (probe-file asdf-file) + (load asdf-file) + (load (make-pathname :host (pathname-host *base-dir*) + :device (pathname-device *base-dir*) + :directory (butlast (pathname-directory *base-dir*)) + :name "asdf" :type "lisp")))) + +(push *base-dir* asdf:*central-registry*) + +(asdf:oos 'asdf:load-op :clfswm-client) + +(in-package :clfswm-client) + + +#-BUILD +(start-client) + Added: clfswm/contrib/server/md5.fas ============================================================================== --- (empty file) +++ clfswm/contrib/server/md5.fas Thu Aug 12 17:30:52 2010 @@ -0,0 +1,1203 @@ +(|SYSTEM|::|VERSION| '(20080430.)) +#0Y_ #0Y |CHARSET|::|UTF-8| +#Y(#:|1 50 (DEFPACKAGE #:MD5 (:USE #:CL) ...)-1-1| + #18Y(00 00 00 00 00 00 00 00 20 01 DA 01 04 31 F0 3E 19 01) ("MD5") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|1 50 (DEFPACKAGE #:MD5 (:USE #:CL) ...)-1-2| + #17Y(00 00 00 00 00 00 00 00 20 01 DA DB 31 EC 3E 19 01) + (("COMMON-LISP") "MD5") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|1 50 (DEFPACKAGE #:MD5 (:USE #:CL) ...)-1-3| + #19Y(00 00 00 00 00 00 00 00 20 01 DA DB 63 2D 03 02 3E 19 01) + (("MD5-REGS" "INITIAL-MD5-REGS" "MD5REGS-DIGEST" "UPDATE-MD5-BLOCK" + "FILL-BLOCK" "FILL-BLOCK-UB8" "FILL-BLOCK-CHAR" "MD5-STATE" "MD5-STATE-P" + "MAKE-MD5-STATE" "UPDATE-MD5-STATE" "FINALIZE-MD5-STATE" "MD5SUM-SEQUENCE" + "MD5SUM-STREAM" "MD5SUM-FILE" "MD5") + "MD5" |SYSTEM|::|INTERN-EXPORT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|1 50 (DEFPACKAGE #:MD5 (:USE #:CL) ...)-1-4| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 D9 19 01) ("MD5") + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) +#Y(#:|52 52 (IN-PACKAGE #:MD5)-2| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("MD5" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|54 70 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (DEFTYPE UB32 NIL ...))-3| + #24Y(00 00 00 00 00 00 00 00 20 01 DA DB DC 32 A2 DA DD DE 2D 03 05 C5 19 + 01) + (|MD5|::|UB32| |SYSTEM|::|DEFTYPE-EXPANDER| + #Y(#:|DEFTYPE-UB32| + #26Y(00 00 00 00 01 00 00 00 20 02 AD DA DA 2D 03 01 1D 03 C8 19 02 AD + 2F 02 19 02) + (1. |SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| + |SYSTEM|::|TYPE-CALL-ERROR| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| + "Corresponds to the 32bit quantity word of the MD5 Spec" + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|72 81 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (DEFMACRO ASSEMBLE-UB32 # ...))-4| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|MD5|::|ASSEMBLE-UB32| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|ASSEMBLE-UB32| + #64Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 63 2D 04 01 1D 28 9F 5C 78 + A0 5C 5C 78 A1 5C 5C 5C 78 B1 71 A2 DD DE DF E0 B0 CC 5D 7A E0 B2 + CD 5D 7A E0 B4 CE 5D 7A B5 7B 05 61 03 19 07 AE 2F 02 19 03) + (5. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |COMMON-LISP|::|THE| |MD5|::|UB32| |COMMON-LISP|::|LOGIOR| + |COMMON-LISP|::|ASH| (24.) (16.) (8.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) + "Assemble an ub32 value from the given (unsigned-byte 8) values,\n +where a is the intended low-order byte and d the high-order byte." + 1) + (|MD5|::|A| |MD5|::|B| |MD5|::|C| |MD5|::|D|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|83 86 (DECLAIM (INLINE F G ...) (FTYPE # F ...))-5-1| + #16Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 3E 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|F| |MD5|::|G| |MD5|::|H| |MD5|::|I|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|83 86 (DECLAIM (INLINE F G ...) (FTYPE # F ...))-5-2| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| (|MD5|::|UB32| |MD5|::|UB32| |MD5|::|UB32|) + |MD5|::|UB32|) + |MD5|::|F| |MD5|::|G| |MD5|::|H| |MD5|::|I|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|88 95 (DEFUN F (X Y Z) ...)-6| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|F| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|F|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|F| + (|COMMON-LISP|::|LOGIOR| (|COMMON-LISP|::|LOGAND| |MD5|::|X| |MD5|::|Y|) + (|COMMON-LISP|::|LOGANDC1| |MD5|::|X| |MD5|::|Z|)))) + #Y(|MD5|::|F| + #24Y(00 00 00 00 03 00 00 00 26 04 AF AF 73 02 40 B0 AF 72 E4 33 02 3E + 19 04) + () (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|97 104 (DEFUN G (X Y Z) ...)-7| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|G| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|G|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|G| + (|COMMON-LISP|::|LOGIOR| (|COMMON-LISP|::|LOGAND| |MD5|::|X| |MD5|::|Z|) + (|COMMON-LISP|::|LOGANDC2| |MD5|::|Y| |MD5|::|Z|)))) + #Y(|MD5|::|G| + #24Y(00 00 00 00 03 00 00 00 26 04 AF AE 73 02 40 AF AF 72 E5 33 02 3E + 19 04) + () (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|106 112 (DEFUN H (X Y Z) ...)-8| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|H| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|H|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|H| + (|COMMON-LISP|::|LOGXOR| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|))) + #Y(|MD5|::|H| #18Y(00 00 00 00 03 00 00 00 26 04 AF AF AF 33 03 3F 19 04) + () (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|114 120 (DEFUN I (X Y Z) ...)-9| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|I| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|I|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|I| + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 32. 0.) + (|COMMON-LISP|::|LOGXOR| |MD5|::|Y| + (|COMMON-LISP|::|LOGORC2| |MD5|::|X| |MD5|::|Z|))))) + #Y(|MD5|::|I| + #23Y(00 00 00 00 03 00 00 00 26 04 DA AF B1 B0 72 E7 73 02 3F 32 F2 19 + 04) + (#S(|COMMON-LISP|::|BYTE| :|SIZE| 32. :|POSITION| 0.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|MD5|::|X| |MD5|::|Y| |MD5|::|Z|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|122 123 (DECLAIM (INLINE MOD32+) (FTYPE # MOD32+))-10-1| + #16Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 3E 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|MOD32+|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|122 123 (DECLAIM (INLINE MOD32+) (FTYPE # MOD32+))-10-2| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| (|MD5|::|UB32| |MD5|::|UB32|) |MD5|::|UB32|) + |MD5|::|MOD32+|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|124 126 (DEFUN MOD32+ (A B) ...)-11| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|MOD32+| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|A| |MD5|::|B|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MOD32+|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|A| |MD5|::|B|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MOD32+| + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 32. 0.) + (|COMMON-LISP|::|+| |MD5|::|A| |MD5|::|B|)))) + #Y(|MD5|::|MOD32+| + #20Y(00 00 00 00 02 00 00 00 26 03 DA AF AF 73 02 37 32 F2 19 03) + (#S(|COMMON-LISP|::|BYTE| :|SIZE| 32. :|POSITION| 0.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|MD5|::|A| |MD5|::|B|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|128 133 (DECLAIM (INLINE ROL32) (FTYPE # ROL32))-12-1| + #16Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 3E 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|ROL32|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|128 133 (DECLAIM (INLINE ROL32) (FTYPE # ROL32))-12-2| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| + (|MD5|::|UB32| (|COMMON-LISP|::|UNSIGNED-BYTE| 5.)) |MD5|::|UB32|) + |MD5|::|ROL32|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|134 142 (DEFUN ROL32 (A S) ...)-13| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|ROL32| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|A| |MD5|::|S|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|ROL32|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|A|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|UNSIGNED-BYTE| 5.) |MD5|::|S|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|ROL32| + (|COMMON-LISP|::|LOGIOR| + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 32. 0.) + (|COMMON-LISP|::|ASH| |MD5|::|A| |MD5|::|S|)) + (|COMMON-LISP|::|ASH| |MD5|::|A| (|COMMON-LISP|::|-| |MD5|::|S| 32.))))) + #Y(|MD5|::|ROL32| + #30Y(00 00 00 00 02 00 00 00 26 03 DA AF AF 72 EC 72 F2 AF DB B0 73 02 + 37 72 EC 33 02 3E 19 03) + (#S(|COMMON-LISP|::|BYTE| :|SIZE| 32. :|POSITION| 0.) -32.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|MD5|::|A| |MD5|::|S|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|144 153 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (DEFPARAMETER *T* #))-14| + #62Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB DC 38 07 C8 FD DE 63 1B 14 DF + AE E0 72 C9 72 BC 72 B9 73 02 39 38 01 72 D0 84 00 85 01 AD DC 91 01 32 + 66 AC 31 B1 16 02 FB 71 1D 31 5A C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |MD5|::|*T*|) |MD5|::|*T*| 64. |MD5|::|UB32| 1. + 4294967296. 0.0d0) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|155 166 (DEFMACRO WITH-MD5-ROUND (# &REST CLAUSES) ...)-15| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|MD5|::|WITH-MD5-ROUND| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|WITH-MD5-ROUND| + #167Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 64 2D 04 01 1D 1C 9F 5C 78 + AC DA DA 63 2D 04 01 1D 15 AC 94 00 9E 5C 78 A3 5C 79 63 AD 01 09 + 1B 80 6E AE 2F 02 19 03 DD DE B1 DF B0 E0 6F 07 E2 B3 E3 33 07 1F + AE AD 80 B8 02 1B 80 4F 87 09 0A 5B 09 08 83 0A 5B FF 83 0A 5B FE + 83 0A 5B FD 83 0A 5B FC 83 0A 5B FB A7 5C 5B FA E4 B5 E5 B6 E6 E5 + E5 BB C1 BC BC BC 7B 04 7B 03 E5 E7 C1 BA 7B 03 6B 0E 97 0C 73 01 + 01 7B 03 7B 03 B5 7B 03 7B 03 7B 03 7B 01 92 01 FF AC 9D F9 FA 16 + 01 83 09 B5 8D 9F FF A8 E9 9E 5D 19 13) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |EXT|::|SOURCE-PROGRAM-ERROR| :|FORM| :|DETAIL| + "~S: ~S does not match lambda list element ~:S" |SYSTEM|::|TEXT| + |MD5|::|WITH-MD5-ROUND| #1=(|MD5|::|OP| |COMMON-LISP|::|BLOCK|) + |COMMON-LISP|::|SETQ| |MD5|::|MOD32+| |MD5|::|ROL32| + |COMMON-LISP|::|AREF| |MD5|::|*T*| |COMMON-LISP|::|PROGN|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) |COMMON-LISP|::|NIL| 1) + (#1# |COMMON-LISP|::|&REST| |MD5|::|CLAUSES|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|168 173 (DEFTYPE MD5-REGS NIL ...)-16| + #24Y(00 00 00 00 00 00 00 00 20 01 DA DB DC 32 A2 DA DD DE 2D 03 05 C5 19 + 01) + (|MD5|::|MD5-REGS| |SYSTEM|::|DEFTYPE-EXPANDER| + #Y(#:|DEFTYPE-MD5-REGS| + #26Y(00 00 00 00 01 00 00 00 20 02 AD DA DA 2D 03 01 1D 03 C8 19 02 AD + 2F 02 19 02) + (1. |SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| + |SYSTEM|::|TYPE-CALL-ERROR| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.) + (4.))) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| + "The working state of the MD5 algorithm, which contains the 4 32-bit\n +registers A, B, C and D." + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|175 176 (DEFMACRO MD5-REGS-A (REGS) ...)-17| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|MD5|::|MD5-REGS-A| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5-REGS-A| + #34Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 63 2D 04 01 1D 0A 9F 5C 78 + DD AD C9 5D 5D 19 04 AE 2F 02 19 03) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |COMMON-LISP|::|AREF| (0.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) |COMMON-LISP|::|NIL| 1) + (|MD5|::|REGS|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|178 179 (DEFMACRO MD5-REGS-B (REGS) ...)-18| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|MD5|::|MD5-REGS-B| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5-REGS-B| + #34Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 63 2D 04 01 1D 0A 9F 5C 78 + DD AD C9 5D 5D 19 04 AE 2F 02 19 03) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |COMMON-LISP|::|AREF| (1.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) |COMMON-LISP|::|NIL| 1) + (|MD5|::|REGS|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|181 182 (DEFMACRO MD5-REGS-C (REGS) ...)-19| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|MD5|::|MD5-REGS-C| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5-REGS-C| + #34Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 63 2D 04 01 1D 0A 9F 5C 78 + DD AD C9 5D 5D 19 04 AE 2F 02 19 03) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |COMMON-LISP|::|AREF| (2.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) |COMMON-LISP|::|NIL| 1) + (|MD5|::|REGS|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|184 185 (DEFMACRO MD5-REGS-D (REGS) ...)-20| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|MD5|::|MD5-REGS-D| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5-REGS-D| + #34Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 63 2D 04 01 1D 0A 9F 5C 78 + DD AD C9 5D 5D 19 04 AE 2F 02 19 03) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |COMMON-LISP|::|AREF| (3.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) |COMMON-LISP|::|NIL| 1) + (|MD5|::|REGS|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|187 188 (DEFCONSTANT +MD5-MAGIC-A+ (ASSEMBLE-UB32 1 35 ...) ...)-21| + #42Y(00 00 00 00 00 00 00 00 20 01 DA 38 01 8D 66 0D DB DA 71 55 8E 13 06 DA + DC DB 2D 03 03 DA DB 32 9D DA DE DF 2D 03 06 C5 19 01) + (|MD5|::|+MD5-MAGIC-A+| 1732584193. + (|COMMON-LISP|::|DEFCONSTANT| |MD5|::|+MD5-MAGIC-A+| + (|MD5|::|ASSEMBLE-UB32| 1. 35. 69. 103.) + #1="Initial value of Register A of the MD5 working state.") + |SYSTEM|::|CONSTANT-WARNING| |COMMON-LISP|::|VARIABLE| #1# + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|189 190 (DEFCONSTANT +MD5-MAGIC-B+ (ASSEMBLE-UB32 137 171 ...) ...)-22| + #42Y(00 00 00 00 00 00 00 00 20 01 DA 38 01 8D 66 0D DB DA 71 55 8E 13 06 DA + DC DB 2D 03 03 DA DB 32 9D DA DE DF 2D 03 06 C5 19 01) + (|MD5|::|+MD5-MAGIC-B+| 4023233417. + (|COMMON-LISP|::|DEFCONSTANT| |MD5|::|+MD5-MAGIC-B+| + (|MD5|::|ASSEMBLE-UB32| 137. 171. 205. 239.) + #1="Initial value of Register B of the MD5 working state.") + |SYSTEM|::|CONSTANT-WARNING| |COMMON-LISP|::|VARIABLE| #1# + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|191 192 (DEFCONSTANT +MD5-MAGIC-C+ (ASSEMBLE-UB32 254 220 ...) ...)-23| + #42Y(00 00 00 00 00 00 00 00 20 01 DA 38 01 8D 66 0D DB DA 71 55 8E 13 06 DA + DC DB 2D 03 03 DA DB 32 9D DA DE DF 2D 03 06 C5 19 01) + (|MD5|::|+MD5-MAGIC-C+| 2562383102. + (|COMMON-LISP|::|DEFCONSTANT| |MD5|::|+MD5-MAGIC-C+| + (|MD5|::|ASSEMBLE-UB32| 254. 220. 186. 152.) + #1="Initial value of Register C of the MD5 working state.") + |SYSTEM|::|CONSTANT-WARNING| |COMMON-LISP|::|VARIABLE| #1# + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|193 194 (DEFCONSTANT +MD5-MAGIC-D+ (ASSEMBLE-UB32 118 84 ...) ...)-24| + #42Y(00 00 00 00 00 00 00 00 20 01 DA 38 01 8D 66 0D DB DA 71 55 8E 13 06 DA + DC DB 2D 03 03 DA DB 32 9D DA DE DF 2D 03 06 C5 19 01) + (|MD5|::|+MD5-MAGIC-D+| 271733878. + (|COMMON-LISP|::|DEFCONSTANT| |MD5|::|+MD5-MAGIC-D+| + (|MD5|::|ASSEMBLE-UB32| 118. 84. 50. 16.) + #1="Initial value of Register D of the MD5 working state.") + |SYSTEM|::|CONSTANT-WARNING| |COMMON-LISP|::|VARIABLE| #1# + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|196 196 (DECLAIM (INLINE INITIAL-MD5-REGS))-25| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|INITIAL-MD5-REGS|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|197 206 (DEFUN INITIAL-MD5-REGS NIL ...)-26| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|INITIAL-MD5-REGS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + (|COMMON-LISP|::|NIL| #1="Create the initial working state of an MD5 run." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|INITIAL-MD5-REGS|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|INITIAL-MD5-REGS| + (|COMMON-LISP|::|LET| + ((|MD5|::|REGS| + (|COMMON-LISP|::|MAKE-ARRAY| 4. :|ELEMENT-TYPE| + '#2=(|COMMON-LISP|::|UNSIGNED-BYTE| 32.)))) + (|COMMON-LISP|::|DECLARE| + (|COMMON-LISP|::|TYPE| |MD5|::|MD5-REGS| |MD5|::|REGS|)) + (|COMMON-LISP|::|SETF| (|MD5|::|MD5-REGS-A| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-A+| (|MD5|::|MD5-REGS-B| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-B+| (|MD5|::|MD5-REGS-C| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-C+| (|MD5|::|MD5-REGS-D| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-D+|) + |MD5|::|REGS|))) + #Y(|MD5|::|INITIAL-MD5-REGS| + #60Y(00 00 00 00 00 00 00 00 26 01 DA 38 07 C6 FD 71 1D 6B 02 AD DD AE + 33 01 02 16 01 6B 04 AD DF AE 33 01 02 16 01 6B 06 AD E1 AE 33 01 + 02 16 01 6B 08 AD E3 AE 33 01 02 16 01 15 19 01) + (4. #2# |MD5|::|+MD5-MAGIC-A+| 0. |MD5|::|+MD5-MAGIC-B+| 1. + |MD5|::|+MD5-MAGIC-C+| 2. |MD5|::|+MD5-MAGIC-D+| 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () #1# 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|208 249 (DEFUN UPDATE-MD5-BLOCK (REGS BLOCK) ...)-27| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|UPDATE-MD5-BLOCK| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|UPDATE-MD5-BLOCK| + #1849Y(00 00 00 00 02 00 00 00 26 03 AE DA 73 01 01 AF DB 73 01 01 B0 DC + 73 01 01 B1 DD 73 01 01 AE B0 B0 B0 B0 6E 03 04 70 05 B3 DA 73 01 + 01 E0 70 05 70 05 E1 70 08 30 05 FB 14 AD B1 B1 B1 6E 03 04 70 05 + B3 DB 73 01 01 E3 70 05 70 05 E4 70 08 30 05 F8 14 AE AE B2 B2 6E + 03 04 70 05 B3 DC 73 01 01 E5 70 05 70 05 E6 70 08 30 05 F9 14 AF + AF AF B3 6E 03 04 70 05 B3 DD 73 01 01 E7 70 05 70 05 E8 70 08 30 + 05 FA 14 B0 B0 B0 B0 6E 03 04 70 05 B3 E9 73 01 01 EA 70 05 70 05 + E1 70 08 30 05 FB 14 AD B1 B1 B1 6E 03 04 70 05 B3 EB 73 01 01 EC + 70 05 70 05 E4 70 08 30 05 F8 14 AE AE B2 B2 6E 03 04 70 05 B3 ED + 73 01 01 EE 70 05 70 05 E6 70 08 30 05 F9 14 AF AF AF B3 6E 03 04 + 70 05 B3 E1 73 01 01 EF 70 05 70 05 E8 70 08 30 05 FA 14 B0 B0 B0 + B0 6E 03 04 70 05 B3 F0 73 01 01 F1 70 05 70 05 E1 70 08 30 05 FB + 14 AD B1 B1 B1 6E 03 04 70 05 B3 F2 73 01 01 F3 70 05 70 05 E4 70 + 08 30 05 F8 14 AE AE B2 B2 6E 03 04 70 05 B3 F4 73 01 01 F5 70 05 + 70 05 E6 70 08 30 05 F9 14 AF AF AF B3 6E 03 04 70 05 B3 F6 73 01 + 01 F7 70 05 70 05 E8 70 08 30 05 FA 14 B0 B0 B0 B0 6E 03 04 70 05 + B3 E4 73 01 01 65 1E 70 05 70 05 E1 70 08 30 05 FB 14 AD B1 B1 B1 + 6E 03 04 70 05 B3 65 1F 73 01 01 65 20 70 05 70 05 E4 70 08 30 05 + F8 14 AE AE B2 B2 6E 03 04 70 05 B3 65 21 73 01 01 65 22 70 05 70 + 05 E6 70 08 30 05 F9 14 AF AF AF B3 6E 03 04 70 05 B3 65 23 73 01 + 01 65 24 70 05 70 05 E8 70 08 30 05 FA 14 B0 B0 B0 B0 6E 03 25 70 + 05 B3 DB 73 01 01 65 26 70 05 70 05 EB 70 08 30 05 FB 14 AD B1 B1 + B1 6E 03 25 70 05 B3 ED 73 01 01 65 27 70 05 70 05 F2 70 08 30 05 + F8 14 AE AE B2 B2 6E 03 25 70 05 B3 F6 73 01 01 65 28 70 05 70 05 + 65 21 70 08 30 05 F9 14 AF AF AF B3 6E 03 25 70 05 B3 DA 73 01 01 + 65 29 70 05 70 05 65 2A 70 08 30 05 FA 14 B0 B0 B0 B0 6E 03 25 70 + 05 B3 EB 73 01 01 65 2B 70 05 70 05 EB 70 08 30 05 FB 14 AD B1 B1 + B1 6E 03 25 70 05 B3 F4 73 01 01 65 2C 70 05 70 05 F2 70 08 30 05 + F8 14 AE AE B2 B2 6E 03 25 70 05 B3 65 23 73 01 01 65 2D 70 05 70 + 05 65 21 70 08 30 05 F9 14 AF AF AF B3 6E 03 25 70 05 B3 E9 73 01 + 01 65 2E 70 05 70 05 65 2A 70 08 30 05 FA 14 B0 B0 B0 B0 6E 03 25 + 70 05 B3 F2 73 01 01 65 2F 70 05 70 05 EB 70 08 30 05 FB 14 AD B1 + B1 B1 6E 03 25 70 05 B3 65 21 73 01 01 65 30 70 05 70 05 F2 70 08 + 30 05 F8 14 AE AE B2 B2 6E 03 25 70 05 B3 DD 73 01 01 65 31 70 05 + 70 05 65 21 70 08 30 05 F9 14 AF AF AF B3 6E 03 25 70 05 B3 F0 73 + 01 01 65 32 70 05 70 05 65 2A 70 08 30 05 FA 14 B0 B0 B0 B0 6E 03 + 25 70 05 B3 65 1F 73 01 01 65 33 70 05 70 05 EB 70 08 30 05 FB 14 + AD B1 B1 B1 6E 03 25 70 05 B3 DC 73 01 01 65 34 70 05 70 05 F2 70 + 08 30 05 F8 14 AE AE B2 B2 6E 03 25 70 05 B3 E1 73 01 01 65 35 70 + 05 70 05 65 21 70 08 30 05 F9 14 AF AF AF B3 6E 03 25 70 05 B3 E4 + 73 01 01 65 36 70 05 70 05 65 2A 70 08 30 05 FA 14 B0 B0 B0 B0 6E + 03 37 70 05 B3 EB 73 01 01 65 38 70 05 70 05 E9 70 08 30 05 FB 14 + AD B1 B1 B1 6E 03 37 70 05 B3 F0 73 01 01 65 39 70 05 70 05 F6 70 + 08 30 05 F8 14 AE AE B2 B2 6E 03 37 70 05 B3 F6 73 01 01 65 3A 70 + 05 70 05 65 3B 70 08 30 05 F9 14 AF AF AF B3 6E 03 37 70 05 B3 65 + 21 73 01 01 65 3C 70 05 70 05 65 3D 70 08 30 05 FA 14 B0 B0 B0 B0 + 6E 03 37 70 05 B3 DB 73 01 01 65 3E 70 05 70 05 E9 70 08 30 05 FB + 14 AD B1 B1 B1 6E 03 37 70 05 B3 E9 73 01 01 65 3F 70 05 70 05 F6 + 70 08 30 05 F8 14 AE AE B2 B2 6E 03 37 70 05 B3 E1 73 01 01 65 40 + 70 05 70 05 65 3B 70 08 30 05 F9 14 AF AF AF B3 6E 03 37 70 05 B3 + F4 73 01 01 65 41 70 05 70 05 65 3D 70 08 30 05 FA 14 B0 B0 B0 B0 + 6E 03 37 70 05 B3 65 1F 73 01 01 65 42 70 05 70 05 E9 70 08 30 05 + FB 14 AD B1 B1 B1 6E 03 37 70 05 B3 DA 73 01 01 65 43 70 05 70 05 + F6 70 08 30 05 F8 14 AE AE B2 B2 6E 03 37 70 05 B3 DD 73 01 01 65 + 44 70 05 70 05 65 3B 70 08 30 05 F9 14 AF AF AF B3 6E 03 37 70 05 + B3 ED 73 01 01 65 45 70 05 70 05 65 3D 70 08 30 05 FA 14 B0 B0 B0 + B0 6E 03 37 70 05 B3 F2 73 01 01 65 46 70 05 70 05 E9 70 08 30 05 + FB 14 AD B1 B1 B1 6E 03 37 70 05 B3 E4 73 01 01 65 47 70 05 70 05 + F6 70 08 30 05 F8 14 AE AE B2 B2 6E 03 37 70 05 B3 65 23 73 01 01 + 65 48 70 05 70 05 65 3B 70 08 30 05 F9 14 AF AF AF B3 6E 03 37 70 + 05 B3 DC 73 01 01 65 49 70 05 70 05 65 3D 70 08 30 05 FA 14 B0 B0 + B0 B0 6E 03 4A 70 05 B3 DA 73 01 01 65 4B 70 05 70 05 ED 70 08 30 + 05 FB 14 AD B1 B1 B1 6E 03 4A 70 05 B3 E1 73 01 01 65 4C 70 05 70 + 05 F4 70 08 30 05 F8 14 AE AE B2 B2 6E 03 4A 70 05 B3 65 21 73 01 + 01 65 4D 70 05 70 05 65 23 70 08 30 05 F9 14 AF AF AF B3 6E 03 4A + 70 05 B3 EB 73 01 01 65 4E 70 05 70 05 65 4F 70 08 30 05 FA 14 B0 + B0 B0 B0 6E 03 4A 70 05 B3 E4 73 01 01 65 50 70 05 70 05 ED 70 08 + 30 05 FB 14 AD B1 B1 B1 6E 03 4A 70 05 B3 DD 73 01 01 65 51 70 05 + 70 05 F4 70 08 30 05 F8 14 AE AE B2 B2 6E 03 4A 70 05 B3 F4 73 01 + 01 65 52 70 05 70 05 65 23 70 08 30 05 F9 14 AF AF AF B3 6E 03 4A + 70 05 B3 DB 73 01 01 65 53 70 05 70 05 65 4F 70 08 30 05 FA 14 B0 + B0 B0 B0 6E 03 4A 70 05 B3 F0 73 01 01 65 54 70 05 70 05 ED 70 08 + 30 05 FB 14 AD B1 B1 B1 6E 03 4A 70 05 B3 65 23 73 01 01 65 55 70 + 05 70 05 F4 70 08 30 05 F8 14 AE AE B2 B2 6E 03 4A 70 05 B3 ED 73 + 01 01 65 56 70 05 70 05 65 23 70 08 30 05 F9 14 AF AF AF B3 6E 03 + 4A 70 05 B3 65 1F 73 01 01 65 57 70 05 70 05 65 4F 70 08 30 05 FA + 14 B0 B0 B0 B0 6E 03 4A 70 05 B3 E9 73 01 01 65 58 70 05 70 05 ED + 70 08 30 05 FB 14 AD B1 B1 B1 6E 03 4A 70 05 B3 F6 73 01 01 65 59 + 70 05 70 05 F4 70 08 30 05 F8 14 AE AE B2 B2 6E 03 4A 70 05 B3 DC + 73 01 01 65 5A 70 05 70 05 65 23 70 08 30 05 F9 14 AF AF AF B3 6E + 03 4A 70 05 B3 F2 73 01 01 65 5B 70 05 70 05 65 4F 70 08 30 05 FA + B2 DA 73 01 01 B0 70 05 B3 DA AE 33 01 02 16 01 B2 DB 73 01 01 AF + 70 05 B3 DB AE 33 01 02 16 01 B2 DC 73 01 01 AE 70 05 B3 DC AE 33 + 01 02 16 01 B2 DD 73 01 01 AD 70 05 B3 DD AE 33 01 02 16 01 A3 19 + 07) + (0. 1. 2. 3. |MD5|::|F| |MD5|::|MOD32+| 3614090360. 7. |MD5|::|ROL32| + 3905402710. 12. 606105819. 17. 3250441966. 22. 4. 4118548399. 5. + 1200080426. 6. 2821735955. 4249261313. 8. 1770035416. 9. 2336552879. + 10. 4294925233. 11. 2304563134. 1804603682. 13. 4254626195. 14. + 2792965006. 15. 1236535329. |MD5|::|G| 4129170786. 3225465664. + 643717713. 3921069994. 20. 3593408605. 38016083. 3634488961. + 3889429448. 568446438. 3275163606. 4107603335. 1163531501. 2850285829. + 4243563512. 1735328473. 2368359562. |MD5|::|H| 4294588738. 2272392833. + 1839030562. 16. 4259657740. 23. 2763975236. 1272893353. 4139469664. + 3200236656. 681279174. 3936430074. 3572445317. 76029189. 3654602809. + 3873151461. 530742520. 3299628645. |MD5|::|I| 4096336452. 1126891415. + 2878612391. 4237533241. 21. 1700485571. 2399980690. 4293915773. + 2240044497. 1873313359. 4264355552. 2734768916. 1309151649. 4149444226. + 3174756917. 718787259. 3951481745.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|MD5|::|REGS| |COMMON-LISP|::|BLOCK|) + "This is the core part of the MD5 algorithm. It takes a complete 16\n +word block of input, and updates the working state in A, B, C, and D\n +accordingly." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|251 253 (DECLAIM (INLINE FILL-BLOCK FILL-BLOCK-UB8 ...))-28| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|FILL-BLOCK| |MD5|::|FILL-BLOCK-UB8| + |MD5|::|FILL-BLOCK-CHAR|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|255 276 (DEFUN FILL-BLOCK-UB8 (BLOCK BUFFER OFFSET) ...)-29| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|FILL-BLOCK-UB8| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|) + #1="Convert a complete 64 (unsigned-byte 8) input vector segment\n +starting from offset into the given 16 word MD5 block." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|FILL-BLOCK-UB8|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777151.) + |MD5|::|OFFSET|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |MD5|::|UB32| (16.)) + |COMMON-LISP|::|BLOCK|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + |MD5|::|BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|FILL-BLOCK-UB8| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|I| |MD5|::|OF-TYPE| + (|COMMON-LISP|::|INTEGER| 0. 16.) |MD5|::|FROM| 0. |MD5|::|FOR| + |MD5|::|J| |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777215.) + |MD5|::|FROM| |MD5|::|OFFSET| |MD5|::|TO| + (|COMMON-LISP|::|+| |MD5|::|OFFSET| 63.) |MD5|::|BY| 4. + |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |COMMON-LISP|::|BLOCK| |MD5|::|I|) + (|MD5|::|ASSEMBLE-UB32| + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| |MD5|::|J|) + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 1.)) + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 2.)) + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 3.))))))) + #Y(|MD5|::|FILL-BLOCK-UB8| + #85Y(00 00 00 00 03 00 00 00 26 04 DA AE DB B0 73 02 37 1B 39 B1 DC AF + 73 02 37 73 01 01 DD 72 EC B2 DE B0 73 02 37 73 01 01 DF 72 EC B3 + 96 04 73 01 01 E0 72 EC B4 B1 73 01 01 73 04 3E B3 B0 AE 33 01 02 + 16 01 85 02 E1 AE 82 02 37 01 AD AD 91 01 32 41 00 19 07) + (0. 63. 3. 24. 2. 16. 8. 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|) #1# 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|278 299 (DEFUN FILL-BLOCK-CHAR (BLOCK BUFFER OFFSET) ...)-30| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|FILL-BLOCK-CHAR| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|) + #1="Convert a complete 64 character input string segment starting from\n +offset into the given 16 word MD5 block." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|FILL-BLOCK-CHAR|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777151.) + |MD5|::|OFFSET|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |MD5|::|UB32| (16.)) + |COMMON-LISP|::|BLOCK|) + (|COMMON-LISP|::|TYPE| |COMMON-LISP|::|SIMPLE-STRING| |MD5|::|BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|FILL-BLOCK-CHAR| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|I| |MD5|::|OF-TYPE| + (|COMMON-LISP|::|INTEGER| 0. 16.) |MD5|::|FROM| 0. |MD5|::|FOR| + |MD5|::|J| |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777215.) + |MD5|::|FROM| |MD5|::|OFFSET| |MD5|::|TO| + (|COMMON-LISP|::|+| |MD5|::|OFFSET| 63.) |MD5|::|BY| 4. + |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |COMMON-LISP|::|BLOCK| |MD5|::|I|) + (|MD5|::|ASSEMBLE-UB32| + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| |MD5|::|J|)) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 1.))) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 2.))) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 3.)))))))) + #Y(|MD5|::|FILL-BLOCK-CHAR| + #90Y(00 00 00 00 03 00 00 00 26 04 DA AE DB B0 73 02 37 1B 3D B1 DC AF + 73 02 37 71 32 71 28 DD 72 EC B2 DE B0 73 02 37 71 32 71 28 DF 72 + EC B3 96 04 71 32 71 28 E0 72 EC B4 B1 71 32 71 28 73 04 3E B3 B0 + AE 33 01 02 16 01 85 02 E1 AE 82 02 37 01 AD AD 91 01 32 FF BC 00 + 19 07) + (0. 63. 3. 24. 2. 16. 8. 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|) #1# 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|301 314 (DEFUN FILL-BLOCK (BLOCK BUFFER OFFSET) ...)-31| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|FILL-BLOCK| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|) + #1="Convert a complete 64 byte input vector segment into the given 16\n +word MD5 block. This currently works on (unsigned-byte 8) and\n +character simple-arrays, via the functions `fill-block-ub8' and\n +`fill-block-char' respectively." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|FILL-BLOCK|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777151.) + |MD5|::|OFFSET|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |MD5|::|UB32| (16.)) + |COMMON-LISP|::|BLOCK|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |COMMON-LISP|::|*| (|COMMON-LISP|::|*|)) + |MD5|::|BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|FILL-BLOCK| + (|COMMON-LISP|::|ETYPECASE| |MD5|::|BUFFER| + (#2=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + (|MD5|::|FILL-BLOCK-UB8| |COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| + |MD5|::|OFFSET|)) + (|COMMON-LISP|::|SIMPLE-STRING| + (|MD5|::|FILL-BLOCK-CHAR| |COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| + |MD5|::|OFFSET|))))) + #Y(|MD5|::|FILL-BLOCK| + #58Y(00 00 00 00 03 00 00 00 26 04 AE 8F 32 0D AE 71 06 DA 8F 14 06 AE + 71 07 24 01 0F AE 8E 36 13 AE DE DF 70 06 E1 2D 03 08 19 04 AF AF + AF 2D 03 02 19 04 AF AF AF 2D 03 03 19 04) + ((|COMMON-LISP|::|UNSIGNED-BYTE| 8.) 1. |MD5|::|FILL-BLOCK-UB8| + |MD5|::|FILL-BLOCK-CHAR| |MD5|::|BUFFER| + (#2# |COMMON-LISP|::|SIMPLE-STRING|) |SYSTEM|::|TYPECASE-ERROR-STRING| + (|COMMON-LISP|::|OR| #2# |COMMON-LISP|::|SIMPLE-STRING|) + |SYSTEM|::|ETYPECASE-FAILED|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|) #1# 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|316 318 (DECLAIM (INLINE MD5REGS-DIGEST))-32| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|MD5REGS-DIGEST|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|319 339 (DEFUN MD5REGS-DIGEST (REGS) ...)-33| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|MD5REGS-DIGEST| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|REGS|) + #1="Create the final 16 byte message-digest from the MD5 working state\n +in regs. Returns a (simple-array (unsigned-byte 8) (16))." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5REGS-DIGEST|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.)) + (|COMMON-LISP|::|TYPE| |MD5|::|MD5-REGS| |MD5|::|REGS|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5REGS-DIGEST| + (|COMMON-LISP|::|LET| + ((|MD5|::|RESULT| + (|COMMON-LISP|::|MAKE-ARRAY| 16. :|ELEMENT-TYPE| + '#2=(|COMMON-LISP|::|UNSIGNED-BYTE| 8.)))) + (|COMMON-LISP|::|DECLARE| + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (16.)) + |MD5|::|RESULT|)) + (|COMMON-LISP|::|MACROLET| + ((|MD5|::|FROB| (|MD5|::|REG| |MD5|::|OFFSET|) + (|COMMON-LISP|::|LET| ((|MD5|::|VAR| (|COMMON-LISP|::|GENSYM|))) + `(|COMMON-LISP|::|LET| ((,|MD5|::|VAR| ,|MD5|::|REG|)) + (|COMMON-LISP|::|DECLARE| + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| ,|MD5|::|VAR|)) + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| ,|MD5|::|OFFSET|) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 0.) + ,|MD5|::|VAR|) + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| + ,(|COMMON-LISP|::|+| |MD5|::|OFFSET| 1.)) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 8.) + ,|MD5|::|VAR|) + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| + ,(|COMMON-LISP|::|+| |MD5|::|OFFSET| 2.)) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 16.) + ,|MD5|::|VAR|) + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| + ,(|COMMON-LISP|::|+| |MD5|::|OFFSET| 3.)) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 24.) + ,|MD5|::|VAR|)))))) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-A| |MD5|::|REGS|) 0.) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-B| |MD5|::|REGS|) 4.) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-C| |MD5|::|REGS|) 8.) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-D| |MD5|::|REGS|) 12.)) + |MD5|::|RESULT|))) + #Y(|MD5|::|MD5REGS-DIGEST| + #237Y(00 00 00 00 01 00 00 00 26 02 DA 38 07 C6 FD 71 1D AE DC 73 01 01 + DD AD 73 02 40 AE DC AE 33 01 02 16 01 DE AD 72 F2 AE DF AE 33 01 + 02 16 01 E0 AD 72 F2 AE E1 AE 33 01 02 16 01 E2 AD 72 F2 AE E3 AE + 33 01 02 16 02 AE DF 73 01 01 DD AD 73 02 40 AE E4 AE 33 01 02 16 + 01 E5 AD 72 F2 AE E6 AE 33 01 02 16 01 E7 AD 72 F2 AE E8 AE 33 01 + 02 16 01 E9 AD 72 F2 AE EA AE 33 01 02 16 02 AE E1 73 01 01 DD AD + 73 02 40 AE EB AE 33 01 02 16 01 EC AD 72 F2 AE ED AE 33 01 02 16 + 01 EE AD 72 F2 AE EF AE 33 01 02 16 01 F0 AD 72 F2 AE F1 AE 33 01 + 02 16 02 AE E3 73 01 01 DD AD 73 02 40 AE F2 AE 33 01 02 16 01 F3 + AD 72 F2 AE F4 AE 33 01 02 16 01 F5 AD 72 F2 AE F6 AE 33 01 02 16 + 01 F7 AD 72 F2 AE 65 1E AE 33 01 02 16 02 15 19 02) + (16. #2# 0. 255. #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 8.) 1. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 16.) 2. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 24.) 3. 4. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 8.) 5. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 16.) 6. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 24.) 7. 8. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 8.) 9. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 16.) 10. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 24.) 11. 12. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 8.) 13. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 16.) 14. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 8. :|POSITION| 24.) 15.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|MD5|::|REGS|) #1# 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|341 355 (DEFSTRUCT (MD5-STATE # #) (REGS # :TYPE ...) ...)-34| + #802Y(00 00 00 00 00 00 00 00 20 01 00 2B 01 DA DB DC 38 01 72 9E 2F 03 5D + 0B 00 00 DE DF E0 DA 2F 07 DA E2 32 A3 DA 68 04 00 63 E3 E4 E5 6B 0C + E7 E8 E9 EA EB EC ED EE EF F0 BF 70 17 F2 F3 F4 F5 F6 64 6E 11 1D 6B + 0C E7 65 1E E9 65 1F EB 65 20 ED EE EF 65 21 65 21 6F 22 70 17 F2 65 + 23 F4 65 24 F6 63 6E 11 1D 6B 0C E7 65 25 E9 65 26 EB 65 27 ED EE EF + 65 28 C0 70 17 F2 65 29 F4 65 2A F6 64 6E 11 1D 6B 0C E7 65 2B E9 65 + 2C EB 65 2D ED EE EF 65 2E C0 70 17 F2 65 2F F4 65 30 F6 64 6E 11 1D + 6B 0C E7 65 31 E9 65 32 EB 65 33 ED EE EF 65 21 65 21 6F 22 70 17 F2 + 65 34 F4 65 35 F6 63 6E 11 1D 6B 0C E7 65 36 E9 65 37 EB 64 ED EE EF + 01 02 6F 22 70 17 F2 65 38 F4 65 39 F6 63 6E 11 1D 7B 06 6B 3A E7 E8 + E9 EA EB EC ED EE EF F0 C0 70 17 F2 65 3B 65 3C 65 3D 65 3E 63 6E 11 + 3F 6B 3A E7 65 1E E9 65 1F EB 65 20 ED EE EF 65 21 65 21 6F 22 70 17 + F2 65 40 65 3C 65 41 65 3E 65 42 6E 11 3F 6B 3A E7 65 25 E9 65 26 EB + 65 27 ED EE EF 65 28 C1 70 17 F2 65 43 65 3C 65 44 65 3E 63 6E 11 3F + 6B 3A E7 65 2B E9 65 2C EB 65 2D ED EE EF 65 2E C1 70 17 F2 65 45 65 + 3C 65 46 65 3E 63 6E 11 3F 6B 3A E7 65 31 E9 65 32 EB 65 33 ED EE EF + 65 21 65 21 6F 22 70 17 F2 65 47 65 3C 65 48 65 3E 65 49 6E 11 3F 6B + 3A E7 65 36 E9 65 37 EB 64 ED EE EF 01 02 6F 22 70 17 F2 65 4A 65 3C + 65 4B 65 3E 65 4C 6E 11 3F 7B 06 2D 08 4D 65 4E 2F 4F 65 4E B0 6D 50 + 01 32 9C 16 04 65 51 31 62 E5 2F 4F E5 65 52 65 53 32 A2 E5 65 54 32 + 9C 65 55 31 62 E4 2F 4F E4 65 52 65 56 32 A2 E4 65 57 32 9C 65 58 31 + 62 65 59 31 62 65 5A 2F 4F 65 5A 65 52 65 5B 32 A2 65 5A 65 5C 32 9C + 65 5A 65 5D DA 32 A2 65 5E 31 62 65 5F 31 62 65 60 2F 4F 65 60 65 52 + 65 61 32 A2 65 60 65 62 32 9C 65 60 65 5D DA 32 A2 65 63 31 62 65 64 + 31 62 65 65 2F 4F 65 65 65 52 65 66 32 A2 65 65 65 67 32 9C 65 65 65 + 5D DA 32 A2 65 68 31 62 65 69 31 62 65 6A 2F 4F 65 6A 65 52 65 6B 32 + A2 65 6A 65 6C 32 9C 65 6A 65 5D DA 32 A2 65 6D 31 62 65 6E 31 62 65 + 6F 2F 4F 65 6F 65 52 65 70 32 A2 65 6F 65 71 32 9C 65 6F 65 5D DA 32 + A2 65 72 31 62 65 73 31 62 65 74 2F 4F 65 74 65 52 65 75 32 A2 65 74 + 65 76 32 9C 65 74 65 5D DA 32 A2 65 77 31 62 65 78 31 62 65 79 2F 4F + 65 79 65 52 65 7A 32 A2 65 79 65 7B 32 9C 65 60 65 7C DA 32 A2 65 7D + 31 62 65 7E 31 62 65 7F 2F 4F 65 7F 65 52 65 80 80 32 A2 65 7F 65 80 + 81 32 9C 65 6F 65 7C DA 32 A2 65 80 82 31 62 65 80 83 31 62 65 80 84 + 2F 4F 65 80 84 65 52 65 80 85 32 A2 65 80 84 65 80 86 32 9C 65 74 65 + 7C DA 32 A2 DA 65 80 87 63 2D 03 80 88 DA 2F 80 89 C5 19 01) + (|MD5|::|MD5-STATE| |COMMON-LISP|::|STRUCTURE-OBJECT| |CLOS|::|CLOSCLASS| + |CLOS|::|CLASS-NAMES| + #Y(|MD5|::|DEFAULT-REGS| #14Y(00 00 00 00 00 00 00 00 26 01 2E 00 19 01) + (|MD5|::|INITIAL-MD5-REGS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1) + #Y(|MD5|::|DEFAULT-BLOCK| + #19Y(00 00 00 00 00 00 00 00 26 01 DA 38 07 C6 FD 31 1D 19 01) + (16. #1=(|COMMON-LISP|::|UNSIGNED-BYTE| 32.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) () + |COMMON-LISP|::|NIL| 1) + #Y(|MD5|::|DEFAULT-BUFFER| + #19Y(00 00 00 00 00 00 00 00 26 01 DA 38 07 C6 FD 31 1D 19 01) + (64. #2=(|COMMON-LISP|::|UNSIGNED-BYTE| 8.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) () + |COMMON-LISP|::|NIL| 1) + |SYSTEM|::|STRUCTURE-UNDEFINE-ACCESSORIES| + |SYSTEM|::|DEFSTRUCT-DESCRIPTION| (|MD5|::|MAKE-MD5-STATE|) + |MD5|::|COPY-MD5-STATE| |MD5|::|MD5-STATE-P| + |CLOS|::|| :|NAME| |MD5|::|REGS| + :|INITARGS| (:|REGS|) :|TYPE| |MD5|::|MD5-REGS| :|ALLOCATION| :|INSTANCE| + |CLOS|::|INHERITABLE-INITER| #3=(|MD5|::|INITIAL-MD5-REGS|) + |CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| |CLOS|::|INHERITABLE-DOC| + (|COMMON-LISP|::|NIL|) |CLOS|::|LOCATION| 1. |CLOS|::|READONLY| + |CLOS|::|MAKE-INSTANCE-| + |MD5|::|AMOUNT| (:|AMOUNT|) + #4=(|COMMON-LISP|::|INTEGER| 0. |COMMON-LISP|::|*|) 0. + |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| (|COMMON-LISP|::|NIL|) 2. + |COMMON-LISP|::|BLOCK| (:|BLOCK|) + #5=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.) + (16.)) + #6=(|COMMON-LISP|::|MAKE-ARRAY| 16. :|ELEMENT-TYPE| '#1#) + (|COMMON-LISP|::|NIL|) 3. |MD5|::|BUFFER| (:|BUFFER|) + #7=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (64.)) + #8=(|COMMON-LISP|::|MAKE-ARRAY| 64. :|ELEMENT-TYPE| '#2#) + (|COMMON-LISP|::|NIL|) 4. |MD5|::|BUFFER-INDEX| (:|BUFFER-INDEX|) + #9=(|COMMON-LISP|::|INTEGER| 0. 63.) (|COMMON-LISP|::|NIL|) 5. + |MD5|::|FINALIZED-P| (:|FINALIZED-P|) (|COMMON-LISP|::|NIL|) 6. + |CLOS|::|| (|COMMON-LISP|::|NIL|) + :|READERS| (|MD5|::|MD5-STATE-REGS|) :|WRITERS| + |CLOS|::|MAKE-INSTANCE-| + (|COMMON-LISP|::|NIL|) (|MD5|::|MD5-STATE-AMOUNT|) + ((|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|)) (|COMMON-LISP|::|NIL|) + (|MD5|::|MD5-STATE-BLOCK|) (|COMMON-LISP|::|NIL|) + (|MD5|::|MD5-STATE-BUFFER|) (|COMMON-LISP|::|NIL|) + (|MD5|::|MD5-STATE-BUFFER-INDEX|) + ((|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|)) + (|COMMON-LISP|::|NIL|) (|MD5|::|MD5-STATE-FINALIZED-P|) + ((|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|)) + |CLOS|::|DEFINE-STRUCTURE-CLASS| |MD5|::|MAKE-MD5-STATE| + |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MAKE-MD5-STATE| + #72Y(00 00 00 00 00 00 00 00 26 01 2E 01 14 DC 38 07 C8 FD 71 1D DE 38 + 07 CA FD 71 1D 69 00 01 E0 72 45 E1 AD E2 B2 32 44 E1 AD E3 E4 32 + 44 E1 AD E5 B1 32 44 E1 AD E6 B0 32 44 E1 AD E7 E4 32 44 E1 AD E8 + 63 32 44 15 19 04) + (|COMMON-LISP|::|NIL| |MD5|::|INITIAL-MD5-REGS| 16. #1# 64. #2# 7. + |MD5|::|MD5-STATE| 1. 2. 0. 3. 4. 5. 6.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&AUX| (|MD5|::|REGS| #3#) (|MD5|::|AMOUNT| 0.) + (|COMMON-LISP|::|BLOCK| #6#) (|MD5|::|BUFFER| #8#) + (|MD5|::|BUFFER-INDEX| 0.) (|MD5|::|FINALIZED-P| |COMMON-LISP|::|NIL|)) + |COMMON-LISP|::|NIL| 1) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-P|) |SYSTEM|::|INLINE-EXPANSION| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-P|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-P| + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT|))) + #Y(|MD5|::|MD5-STATE-P| + #16Y(00 00 00 00 01 00 00 00 20 02 DA AE 32 47 19 02) + (|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|INLINE| |MD5|::|COPY-MD5-STATE|) + ((|COMMON-LISP|::|STRUCTURE|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|COPY-MD5-STATE|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|COPY-MD5-STATE| + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|))) + #Y(|MD5|::|COPY-MD5-STATE| + #15Y(00 00 00 00 01 00 00 00 26 02 AD 32 46 19 02) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|STRUCTURE|) |COMMON-LISP|::|NIL| 1) + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-REGS| (|MD5|::|MD5-STATE|) + |MD5|::|MD5-REGS|) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-REGS|) |MD5|::|MD5-STATE-REGS| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-REGS|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-REGS| + (|COMMON-LISP|::|THE| |MD5|::|MD5-REGS| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| + 1.)))) + #Y(|MD5|::|MD5-STATE-REGS| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|MD5|::|MD5-STATE| 1.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + |SYSTEM|::|DEFSTRUCT-READER| + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-AMOUNT| (|MD5|::|MD5-STATE|) + #4#) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-AMOUNT|) + |MD5|::|MD5-STATE-AMOUNT| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-AMOUNT|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-AMOUNT| + (|COMMON-LISP|::|THE| #4# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| + 2.)))) + #Y(|MD5|::|MD5-STATE-AMOUNT| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|MD5|::|MD5-STATE| 2.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BLOCK| (|MD5|::|MD5-STATE|) + #5#) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BLOCK|) |MD5|::|MD5-STATE-BLOCK| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-BLOCK|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BLOCK| + (|COMMON-LISP|::|THE| #5# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| + 3.)))) + #Y(|MD5|::|MD5-STATE-BLOCK| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|MD5|::|MD5-STATE| 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BUFFER| (|MD5|::|MD5-STATE|) + #7#) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BUFFER|) + |MD5|::|MD5-STATE-BUFFER| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-BUFFER|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BUFFER| + (|COMMON-LISP|::|THE| #7# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| + 4.)))) + #Y(|MD5|::|MD5-STATE-BUFFER| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|MD5|::|MD5-STATE| 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|MD5|::|MD5-STATE|) #9#) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BUFFER-INDEX|) + |MD5|::|MD5-STATE-BUFFER-INDEX| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-BUFFER-INDEX|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|COMMON-LISP|::|THE| #9# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| + 5.)))) + #Y(|MD5|::|MD5-STATE-BUFFER-INDEX| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|MD5|::|MD5-STATE| 5.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-FINALIZED-P| + (|MD5|::|MD5-STATE|) |COMMON-LISP|::|T|) + (|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-FINALIZED-P|) + |MD5|::|MD5-STATE-FINALIZED-P| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-FINALIZED-P|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-FINALIZED-P| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|T| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| + 6.)))) + #Y(|MD5|::|MD5-STATE-FINALIZED-P| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|MD5|::|MD5-STATE| 6.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|) (#4# |MD5|::|MD5-STATE|) + #4#) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|MD5|::|MD5-STATE-AMOUNT|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #10=(|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-AMOUNT| + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| #4# . #11=(|SYSTEM|::|VALUE|))))) + #Y(#10# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|MD5|::|MD5-STATE| 2.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |SYSTEM|::|DEFSTRUCT-WRITER| + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|) + (#9# |MD5|::|MD5-STATE|) #9#) + (|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|MD5|::|MD5-STATE-BUFFER-INDEX|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #12=(|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 5. + (|COMMON-LISP|::|THE| #9# . #11#)))) + #Y(#12# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|MD5|::|MD5-STATE| 5.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|) + (|COMMON-LISP|::|T| |MD5|::|MD5-STATE|) |COMMON-LISP|::|T|) + (|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|MD5|::|MD5-STATE-FINALIZED-P|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #13=(|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-FINALIZED-P| + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 6. + |SYSTEM|::|VALUE|))) + #Y(#13# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|MD5|::|MD5-STATE| 6.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| |SYSTEM|::|%SET-DOCUMENTATION| + |CLOS|::|DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|357 357 (DECLAIM (INLINE COPY-TO-BUFFER))-35| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|INLINE| |MD5|::|COPY-TO-BUFFER|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|358 389 (DEFUN COPY-TO-BUFFER (FROM FROM-OFFSET COUNT ...) ...)-36| + #25Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 32 A2 DA DE 32 9C C5 19 + 01) + (|MD5|::|COPY-TO-BUFFER| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + |SYSTEM|::|INLINE-EXPANSION| + ((|MD5|::|FROM| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT| |MD5|::|BUFFER| + |MD5|::|BUFFER-OFFSET|) + #1="Copy a partial segment from input vector from starting at\n +from-offset and copying count elements into the 64 byte buffer\n +starting at buffer-offset." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|COPY-TO-BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.)) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|UNSIGNED-BYTE| 29.) + |MD5|::|FROM-OFFSET|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 63.) + |COMMON-LISP|::|COUNT| |MD5|::|BUFFER-OFFSET|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |COMMON-LISP|::|*| (|COMMON-LISP|::|*|)) + |MD5|::|FROM|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (64.)) + |MD5|::|BUFFER|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|COPY-TO-BUFFER| + (|COMMON-LISP|::|ETYPECASE| |MD5|::|FROM| + (|COMMON-LISP|::|SIMPLE-STRING| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|BUFFER-INDEX| + |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 64.) |MD5|::|FROM| + |MD5|::|BUFFER-OFFSET| |MD5|::|FOR| |MD5|::|FROM-INDEX| + |MD5|::|OF-TYPE| |COMMON-LISP|::|FIXNUM| |MD5|::|FROM| + |MD5|::|FROM-OFFSET| |MD5|::|BELOW| + (|COMMON-LISP|::|+| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT|) + |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| |MD5|::|BUFFER-INDEX|) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| |MD5|::|FROM|) + |MD5|::|FROM-INDEX|))))) + (#2=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|BUFFER-INDEX| + |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 64.) |MD5|::|FROM| + |MD5|::|BUFFER-OFFSET| |MD5|::|FOR| |MD5|::|FROM-INDEX| + |MD5|::|OF-TYPE| |COMMON-LISP|::|FIXNUM| |MD5|::|FROM| + |MD5|::|FROM-OFFSET| |MD5|::|BELOW| + (|COMMON-LISP|::|+| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT|) + |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| |MD5|::|BUFFER-INDEX|) + (|COMMON-LISP|::|AREF| + (|COMMON-LISP|::|THE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + |MD5|::|FROM|) + |MD5|::|FROM-INDEX|))))))) + #Y(|MD5|::|COPY-TO-BUFFER| + #110Y(00 00 00 00 05 00 00 00 26 06 B1 8E 36 1C B1 8F 32 0D B1 71 06 DA + 8F 14 06 B1 71 07 24 01 2C B1 DC DD 70 04 DF 2D 03 06 19 06 AD B1 + B2 B2 73 02 37 AD AD 90 01 34 34 B4 AE 71 32 71 28 B2 B0 AE 33 01 + 02 16 01 85 02 85 01 1B 66 AD B1 B2 B2 73 02 37 1B 11 B4 AE 73 01 + 01 B2 B0 AE 33 01 02 16 01 85 02 85 01 AD AD 91 01 34 69 00 19 09) + ((|COMMON-LISP|::|UNSIGNED-BYTE| 8.) 1. |MD5|::|FROM| + (|COMMON-LISP|::|SIMPLE-STRING| #2#) |SYSTEM|::|TYPECASE-ERROR-STRING| + (|COMMON-LISP|::|OR| |COMMON-LISP|::|SIMPLE-STRING| #2#) + |SYSTEM|::|ETYPECASE-FAILED|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|MD5|::|FROM| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT| + |MD5|::|BUFFER| |MD5|::|BUFFER-OFFSET|) + #1# 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|391 465 (DEFUN UPDATE-MD5-STATE (STATE SEQUENCE &KEY ...) ...)-37| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|UPDATE-MD5-STATE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|UPDATE-MD5-STATE| + #324Y(00 00 00 00 02 00 00 00 A6 1D 02 00 00 00 3B 02 02 C7 FA 3B 01 04 + AF 81 62 01 DD B1 DE 72 43 DD B2 DF 72 43 DD B3 E0 72 43 DD B4 E1 + 72 43 8E AC 80 4C DD B4 E1 72 43 E2 AD 73 01 38 B2 B4 73 01 38 AD + AD 73 01 36 B6 B6 AE B3 B3 2D 05 09 DD B8 E4 72 43 AD 73 02 37 DD + B9 E4 AF 32 44 16 01 B5 AD 82 02 37 09 AD AF 90 01 31 80 4F B1 B1 + DC 2D 03 0B B2 B2 30 0C DD B8 E1 DC 32 44 16 04 B1 B1 90 01 34 34 + B2 8F 32 0D B2 71 06 E7 8F 14 06 B2 71 07 24 04 36 B2 8E 36 80 6A + B2 E9 EA 70 11 EC 2D 03 13 DD B4 E4 72 43 B1 B3 73 01 38 73 02 37 + DD B5 E4 AF 32 44 16 01 A4 19 08 AF AD 73 02 37 DD B9 E1 AF 32 44 + 16 05 1B FF B3 B1 1B 10 AE B4 AE 2D 03 0B AF AF 30 0C E2 AD 82 02 + 37 00 AC B2 90 01 34 0A B1 AD 73 01 38 E2 91 01 31 60 B1 AD 73 01 + 38 AC 8E AC 08 B4 AE AE B1 DC 2D 05 09 DD B6 CC 1B 37 B1 1B 10 AE + B4 AE 2D 03 0E AF AF 30 0C E2 AD 82 02 37 00 AC B2 90 01 34 0A B1 + AD 73 01 38 E2 91 01 31 60 B1 AD 73 01 38 AC 8E AC 08 B4 AE AE B1 + DC 2D 05 09 DD B6 CC 14 AF 32 44 16 02 1B FF 5F) + (:|START| :|END| 0. |MD5|::|MD5-STATE| 1. 3. 4. 5. 64. + |MD5|::|COPY-TO-BUFFER| 2. |MD5|::|FILL-BLOCK-UB8| + |MD5|::|UPDATE-MD5-BLOCK| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + |MD5|::|FILL-BLOCK-CHAR| |COMMON-LISP|::|SEQUENCE| + (#1=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + |COMMON-LISP|::|SIMPLE-STRING|) + |SYSTEM|::|TYPECASE-ERROR-STRING| + (|COMMON-LISP|::|OR| #1# |COMMON-LISP|::|SIMPLE-STRING|) + |SYSTEM|::|ETYPECASE-FAILED|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|MD5|::|STATE| |COMMON-LISP|::|SEQUENCE| |COMMON-LISP|::|&KEY| + (|MD5|::|START| 0.) + (|MD5|::|END| (|COMMON-LISP|::|LENGTH| |COMMON-LISP|::|SEQUENCE|))) + "Update the given md5-state from sequence, which is either a\n +simple-string or a simple-array with element-type (unsigned-byte 8),\n +bounded by start and end, which must be numeric bounding-indices." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|467 510 (DEFUN FINALIZE-MD5-STATE (STATE) ...)-38| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|FINALIZE-MD5-STATE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|FINALIZE-MD5-STATE| + #149Y(00 00 00 00 01 00 00 00 26 02 DA AE DB 32 43 1E 80 81 DA AE DC 72 + 43 DA AF DD 72 43 DA B0 DE 72 43 DA B1 DF 72 43 E0 DA B3 E1 72 43 + 73 02 39 AE AE E2 33 01 02 96 01 1B 08 AF AD E4 33 01 02 85 00 AC + E3 91 01 34 72 16 01 AF AF E4 2D 03 0B AD E6 91 01 34 17 B0 B0 30 + 0D E4 1B 08 B0 AD E4 33 01 02 85 00 AC E8 91 01 34 72 16 01 E9 AD + 72 F2 B0 EA AE 33 01 02 16 01 EB AD 72 F2 B0 EC AE 33 01 02 16 01 + B0 B0 30 0D B0 6F 13 DA B4 DB AF 32 44 19 08 19 02) + (|MD5|::|MD5-STATE| 6. 1. 3. 4. 5. 8. 2. 128. 64. 0. + |MD5|::|FILL-BLOCK-UB8| 56. |MD5|::|UPDATE-MD5-BLOCK| 16. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 32. :|POSITION| 0.) 14. + #S(|COMMON-LISP|::|BYTE| :|SIZE| 32. :|POSITION| 32.) 15. + |MD5|::|MD5REGS-DIGEST|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|MD5|::|STATE|) + "If the given md5-state has not already been finalized, finalize it,\n +by processing any remaining input in its buffer, with suitable padding\n +and appended bit-length, as specified by the MD5 standard.\n\n +The resulting MD5 message-digest is returned as an array of sixteen\n +(unsigned-byte 8) values. Calling `update-md5-state' after a call to\n +`finalize-md5-state' results in unspecified behaviour." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|512 530 (DEFUN MD5SUM-SEQUENCE (SEQUENCE &KEY # ...) ...)-39| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|MD5SUM-SEQUENCE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5SUM-SEQUENCE| + #47Y(00 00 00 00 01 00 00 00 A6 1C 02 00 00 00 3B 02 02 C7 FA 3D 01 2E + 03 14 92 02 03 B0 32 62 14 AD B2 DA B3 DB B1 2D 06 04 16 01 AC 2F + 05 19 05) + (:|START| :|END| 0. |MD5|::|MAKE-MD5-STATE| |MD5|::|UPDATE-MD5-STATE| + |MD5|::|FINALIZE-MD5-STATE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|SEQUENCE| |COMMON-LISP|::|&KEY| (|MD5|::|START| 0.) + |MD5|::|END|) + "Calculate the MD5 message-digest of data in sequence. On CMU CL\n +this works for all sequences whose element-type is supported by the\n +underlying MD5 routines, on other implementations it only works for 1d\n +simple-arrays with such element types." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|532 535 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) (DEFCONSTANT +BUFFER-SIZE+ # ...))-40| + #42Y(00 00 00 00 00 00 00 00 20 01 DA 38 01 8D 66 0D DB DA 71 55 8E 13 06 DA + DC DB 2D 03 03 DA DB 32 9D DA DE DF 2D 03 06 C5 19 01) + (|MD5|::|+BUFFER-SIZE+| 131072. + (|COMMON-LISP|::|DEFCONSTANT| |MD5|::|+BUFFER-SIZE+| + (|COMMON-LISP|::|*| 128. 1024.) + #1="Size of internal buffer to use for md5sum-stream and md5sum-file\n +operations. This should be a multiple of 64, the MD5 block size.") + |SYSTEM|::|CONSTANT-WARNING| |COMMON-LISP|::|VARIABLE| #1# + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|537 537 (DEFTYPE BUFFER-INDEX NIL ...)-41| + #24Y(00 00 00 00 00 00 00 00 20 01 DA DB DC 32 A2 DA DD 63 2D 03 04 C5 19 + 01) + (|MD5|::|BUFFER-INDEX| |SYSTEM|::|DEFTYPE-EXPANDER| + #Y(#:|DEFTYPE-BUFFER-INDEX| + #26Y(00 00 00 00 01 00 00 00 20 02 AD DA DA 2D 03 01 1D 03 C8 19 02 AD + 2F 02 19 02) + (1. |SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| + |SYSTEM|::|TYPE-CALL-ERROR| (|COMMON-LISP|::|INTEGER| 0. 131072.)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|539 566 (DEFUN MD5SUM-STREAM (STREAM) ...)-42| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|MD5SUM-STREAM| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5SUM-STREAM| + #95Y(00 00 00 00 01 00 00 00 26 02 2E 00 14 AE 6F 01 DC 8E 14 25 AE 6F + 01 25 0A 3D 6B 03 38 02 71 49 DF AD B1 30 06 F8 AE AE E1 AF 2D 04 + 08 AC 6B 03 91 01 31 6D AE 2F 09 19 05 6B 03 38 07 C9 FD 71 1D DF + AD B1 30 06 F8 AE AE E1 AF 2D 04 08 AC 6B 03 91 01 31 6D 1B 5D E5 + AF 6F 01 B0 33 02 1E) + (|MD5|::|MAKE-MD5-STATE| |COMMON-LISP|::|STREAM-ELEMENT-TYPE| + (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) |MD5|::|+BUFFER-SIZE+| + (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) 0. |COMMON-LISP|::|READ-SEQUENCE| + :|END| |MD5|::|UPDATE-MD5-STATE| |MD5|::|FINALIZE-MD5-STATE| + |COMMON-LISP|::|CHARACTER| + "Unsupported stream element-type ~S for stream ~S.") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|STREAM|) + "Calculate an MD5 message-digest of the contents of stream. Its\n +element-type has to be either (unsigned-byte 8) or character." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|568 572 (DEFUN MD5SUM-FILE (PATHNAME) ...)-43| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|MD5SUM-FILE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5SUM-FILE| + #59Y(03 00 01 00 01 00 00 00 26 02 AD 38 06 C5 FC 72 0B 53 19 C6 45 AF + 2F 02 41 05 00 00 02 1D 03 14 2F 03 46 54 05 00 00 00 1D 0E 1B 06 + 05 00 00 00 1D 06 14 DE 64 2D 03 03 55 19 03) + ((|COMMON-LISP|::|UNSIGNED-BYTE| 8.) #.#'|COMMON-LISP|::|VALUES| + |MD5|::|MD5SUM-STREAM| |COMMON-LISP|::|CLOSE| :|ABORT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|PATHNAME|) + "Calculate the MD5 message-digest of the file specified by pathname." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|576 578 (DEFUN MD5-STRING (MD5-DIGEST) ...)-44| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|MD5-STRING| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5-STRING| + #69Y(00 00 00 00 01 00 00 00 26 02 38 02 72 8F DA DB B0 73 00 27 38 01 + AE 71 9D 72 8F AD 1B 0E AD 01 02 DC DD 01 02 94 07 83 08 2D 08 04 + AC 8D 9F 6E 16 01 AC 72 90 38 02 71 4D AF 38 02 31 95 16 02 AC 32 + 90 19 03) + (|COMMON-LISP|::|LIST| #.#'|COMMON-LISP|::|IDENTITY| 2. #\0 + |SYSTEM|::|DO-FORMAT-HEXADECIMAL|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|MD5|::|MD5-DIGEST|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|581 582 (DEFUN MD5 (SEQUENCE) ...)-45| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|MD5|::|MD5| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|MD5|::|MD5| #17Y(00 00 00 00 01 00 00 00 26 02 AD 6F 00 2F 01 19 02) + (|MD5|::|MD5SUM-SEQUENCE| |MD5|::|MD5-STRING|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|SEQUENCE|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) Added: clfswm/contrib/server/md5.lib ============================================================================== --- (empty file) +++ clfswm/contrib/server/md5.lib Thu Aug 12 17:30:52 2010 @@ -0,0 +1,946 @@ +#0Y_ #0Y |CHARSET|::|UTF-8| +(|SYSTEM|::|%IN-PACKAGE| "MD5" :|NICKNAMES| '|COMMON-LISP|::|NIL| :|USE| + '|COMMON-LISP|::|NIL| :|CASE-SENSITIVE| |COMMON-LISP|::|NIL| :|CASE-INVERTED| + |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|USE-PACKAGE| '("COMMON-LISP") "MD5") +(|SYSTEM|::|INTERN-EXPORT| + '("MD5-REGS" "INITIAL-MD5-REGS" "MD5REGS-DIGEST" "UPDATE-MD5-BLOCK" + "FILL-BLOCK" "FILL-BLOCK-UB8" "FILL-BLOCK-CHAR" "MD5-STATE" "MD5-STATE-P" + "MAKE-MD5-STATE" "UPDATE-MD5-STATE" "FINALIZE-MD5-STATE" "MD5SUM-SEQUENCE" + "MD5SUM-STREAM" "MD5SUM-FILE" "MD5") + "MD5" |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|FIND-PACKAGE| "MD5") +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "MD5")) +(|COMMON-LISP|::|DEFTYPE| |MD5|::|UB32| |COMMON-LISP|::|NIL| + "Corresponds to the 32bit quantity word of the MD5 Spec" + `(|COMMON-LISP|::|UNSIGNED-BYTE| 32.)) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|SYSTEM|::|%PUT| '|MD5|::|UB32| '|SYSTEM|::|DEFTYPE-EXPANDER| + (|COMMON-LISP|::|FUNCTION| #:|DEFTYPE-UB32| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::||) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 1. + 1.)) + (|SYSTEM|::|TYPE-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|BLOCK| |MD5|::|UB32| + `(|COMMON-LISP|::|UNSIGNED-BYTE| 32.))))))) + (|SYSTEM|::|%SET-DOCUMENTATION| '|MD5|::|UB32| '|COMMON-LISP|::|TYPE| + '"Corresponds to the 32bit quantity word of the MD5 Spec") + '|MD5|::|UB32|) +(|COMMON-LISP|::|DEFMACRO| |MD5|::|ASSEMBLE-UB32| + (|MD5|::|A| |MD5|::|B| |MD5|::|C| |MD5|::|D|) + "Assemble an ub32 value from the given (unsigned-byte 8) values,\n +where a is the intended low-order byte and d the high-order byte." + `(|COMMON-LISP|::|THE| |MD5|::|UB32| + (|COMMON-LISP|::|LOGIOR| (|COMMON-LISP|::|ASH| ,|MD5|::|D| 24.) + (|COMMON-LISP|::|ASH| ,|MD5|::|C| 16.) + (|COMMON-LISP|::|ASH| ,|MD5|::|B| 8.) ,|MD5|::|A|))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|MD5|::|ASSEMBLE-UB32|) +(|SYSTEM|::|%PUTD| '|MD5|::|ASSEMBLE-UB32| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |MD5|::|ASSEMBLE-UB32| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + "Assemble an ub32 value from the given (unsigned-byte 8) values,\n +where a is the intended low-order byte and d the high-order byte." + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 5. 5. + |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|MD5|::|A| (|COMMON-LISP|::|CADR| . #1=(|SYSTEM|::||))) + (|MD5|::|B| (|COMMON-LISP|::|CADDR| . #1#)) + (|MD5|::|C| (|COMMON-LISP|::|CADDDR| . #1#)) + (|MD5|::|D| (|COMMON-LISP|::|FIFTH| . #1#))) + (|COMMON-LISP|::|BLOCK| |MD5|::|ASSEMBLE-UB32| + `(|COMMON-LISP|::|THE| |MD5|::|UB32| + (|COMMON-LISP|::|LOGIOR| (|COMMON-LISP|::|ASH| ,|MD5|::|D| 24.) + (|COMMON-LISP|::|ASH| ,|MD5|::|C| 16.) + (|COMMON-LISP|::|ASH| ,|MD5|::|B| 8.) ,|MD5|::|A|))))))) + '(|MD5|::|A| |MD5|::|B| |MD5|::|C| |MD5|::|D|))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|F| |MD5|::|G| |MD5|::|H| |MD5|::|I|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| (|MD5|::|UB32| |MD5|::|UB32| |MD5|::|UB32|) + |MD5|::|UB32|) + |MD5|::|F| |MD5|::|G| |MD5|::|H| |MD5|::|I|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|F| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|X| |MD5|::|Y| |MD5|::|Z|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|F|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|F| + (|COMMON-LISP|::|LOGIOR| (|COMMON-LISP|::|LOGAND| |MD5|::|X| |MD5|::|Y|) + (|COMMON-LISP|::|LOGANDC1| |MD5|::|X| |MD5|::|Z|))))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|G| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|X| |MD5|::|Y| |MD5|::|Z|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|G|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|G| + (|COMMON-LISP|::|LOGIOR| (|COMMON-LISP|::|LOGAND| |MD5|::|X| |MD5|::|Z|) + (|COMMON-LISP|::|LOGANDC2| |MD5|::|Y| |MD5|::|Z|))))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|H| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|X| |MD5|::|Y| |MD5|::|Z|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|H|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|H| + (|COMMON-LISP|::|LOGXOR| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|)))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|I| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|X| |MD5|::|Y| |MD5|::|Z|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|I|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|X| |MD5|::|Y| |MD5|::|Z|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|I| + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 32. 0.) + (|COMMON-LISP|::|LOGXOR| |MD5|::|Y| + (|COMMON-LISP|::|LOGORC2| |MD5|::|X| |MD5|::|Z|)))))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MOD32+|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| (|MD5|::|UB32| |MD5|::|UB32|) |MD5|::|UB32|) + |MD5|::|MOD32+|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MOD32+| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|A| |MD5|::|B|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MOD32+|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|A| |MD5|::|B|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MOD32+| + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 32. 0.) + (|COMMON-LISP|::|+| |MD5|::|A| |MD5|::|B|))))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|ROL32|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| + (|MD5|::|UB32| (|COMMON-LISP|::|UNSIGNED-BYTE| 5.)) |MD5|::|UB32|) + |MD5|::|ROL32|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|ROL32| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|A| |MD5|::|S|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|ROL32|) + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| |MD5|::|A|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|UNSIGNED-BYTE| 5.) |MD5|::|S|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|ROL32| + (|COMMON-LISP|::|LOGIOR| + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 32. 0.) + (|COMMON-LISP|::|ASH| |MD5|::|A| |MD5|::|S|)) + (|COMMON-LISP|::|ASH| |MD5|::|A| (|COMMON-LISP|::|-| |MD5|::|S| 32.)))))) +(|COMMON-LISP|::|DEFPARAMETER| |MD5|::|*T*| + (|COMMON-LISP|::|MAKE-ARRAY| 64. :|ELEMENT-TYPE| '|MD5|::|UB32| + :|INITIAL-CONTENTS| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|I| |MD5|::|FROM| 1. |MD5|::|TO| + 64. |MD5|::|COLLECT| + (|COMMON-LISP|::|TRUNCATE| + (|COMMON-LISP|::|*| 4294967296. + (|COMMON-LISP|::|ABS| + (|COMMON-LISP|::|SIN| (|COMMON-LISP|::|FLOAT| |MD5|::|I| 0.0d0)))))))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|SPECIAL| |MD5|::|*T*|)) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|MD5|::|WITH-MD5-ROUND|) +(|SYSTEM|::|%PUTD| '|MD5|::|WITH-MD5-ROUND| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |MD5|::|WITH-MD5-ROUND| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|T|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((#1=#:|G46376| (|COMMON-LISP|::|CADR| . #2=(|SYSTEM|::||))) + (#3=#:|G46377| + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| #1# 2. 2. |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|ERROR-OF-TYPE| '|EXT|::|SOURCE-PROGRAM-ERROR| :|FORM| + |SYSTEM|::|| :|DETAIL| #1# + (|SYSTEM|::|TEXT| "~S: ~S does not match lambda list element ~:S") + '|MD5|::|WITH-MD5-ROUND| #1# + '#4=(|MD5|::|OP| |COMMON-LISP|::|BLOCK|)) + #1#)) + (|MD5|::|OP| (|COMMON-LISP|::|CAR| #3#)) + (|COMMON-LISP|::|BLOCK| (|COMMON-LISP|::|CADR| #3#)) + (|MD5|::|CLAUSES| (|COMMON-LISP|::|CDDR| . #2#))) + (|COMMON-LISP|::|BLOCK| |MD5|::|WITH-MD5-ROUND| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| + (|MD5|::|A| |MD5|::|B| |MD5|::|C| |MD5|::|D| |MD5|::|K| |MD5|::|S| + |MD5|::|I|) + |MD5|::|IN| |MD5|::|CLAUSES| |MD5|::|COLLECT| + `(|COMMON-LISP|::|SETQ| ,|MD5|::|A| + (|MD5|::|MOD32+| ,|MD5|::|B| + (|MD5|::|ROL32| + (|MD5|::|MOD32+| + (|MD5|::|MOD32+| ,|MD5|::|A| + (,|MD5|::|OP| ,|MD5|::|B| ,|MD5|::|C| ,|MD5|::|D|)) + (|MD5|::|MOD32+| + (|COMMON-LISP|::|AREF| ,|COMMON-LISP|::|BLOCK| ,|MD5|::|K|) + ,(|COMMON-LISP|::|AREF| |MD5|::|*T*| + (|COMMON-LISP|::|1-| |MD5|::|I|)))) + ,|MD5|::|S|))) + |MD5|::|INTO| |MD5|::|RESULT| |MD5|::|FINALLY| + (|COMMON-LISP|::|RETURN| + `(|COMMON-LISP|::|PROGN| ,@|MD5|::|RESULT|)))))))) + '(#4# |COMMON-LISP|::|&REST| |MD5|::|CLAUSES|))) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|SYSTEM|::|%PUT| '|MD5|::|MD5-REGS| '|SYSTEM|::|DEFTYPE-EXPANDER| + (|COMMON-LISP|::|FUNCTION| #:|DEFTYPE-MD5-REGS| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::||) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 1. + 1.)) + (|SYSTEM|::|TYPE-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-REGS| + `(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.) + (4.)))))))) + (|SYSTEM|::|%SET-DOCUMENTATION| '|MD5|::|MD5-REGS| '|COMMON-LISP|::|TYPE| + '"The working state of the MD5 algorithm, which contains the 4 32-bit\n +registers A, B, C and D.") + '|MD5|::|MD5-REGS|) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|MD5|::|MD5-REGS-A|) +(|SYSTEM|::|%PUTD| '|MD5|::|MD5-REGS-A| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-REGS-A| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|MD5|::|REGS| (|COMMON-LISP|::|CADR| |SYSTEM|::||))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-REGS-A| + `(|COMMON-LISP|::|AREF| ,|MD5|::|REGS| 0.)))))) + '(|MD5|::|REGS|))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|MD5|::|MD5-REGS-B|) +(|SYSTEM|::|%PUTD| '|MD5|::|MD5-REGS-B| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-REGS-B| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|MD5|::|REGS| (|COMMON-LISP|::|CADR| |SYSTEM|::||))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-REGS-B| + `(|COMMON-LISP|::|AREF| ,|MD5|::|REGS| 1.)))))) + '(|MD5|::|REGS|))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|MD5|::|MD5-REGS-C|) +(|SYSTEM|::|%PUTD| '|MD5|::|MD5-REGS-C| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-REGS-C| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|MD5|::|REGS| (|COMMON-LISP|::|CADR| |SYSTEM|::||))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-REGS-C| + `(|COMMON-LISP|::|AREF| ,|MD5|::|REGS| 2.)))))) + '(|MD5|::|REGS|))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|MD5|::|MD5-REGS-D|) +(|SYSTEM|::|%PUTD| '|MD5|::|MD5-REGS-D| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-REGS-D| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|MD5|::|REGS| (|COMMON-LISP|::|CADR| |SYSTEM|::||))) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-REGS-D| + `(|COMMON-LISP|::|AREF| ,|MD5|::|REGS| 3.)))))) + '(|MD5|::|REGS|))) +(|SYSTEM|::|C-PROCLAIM-CONSTANT| '|MD5|::|+MD5-MAGIC-A+| + '(|MD5|::|ASSEMBLE-UB32| 1. 35. 69. 103.)) +(|SYSTEM|::|C-PROCLAIM-CONSTANT| '|MD5|::|+MD5-MAGIC-B+| + '(|MD5|::|ASSEMBLE-UB32| 137. 171. 205. 239.)) +(|SYSTEM|::|C-PROCLAIM-CONSTANT| '|MD5|::|+MD5-MAGIC-C+| + '(|MD5|::|ASSEMBLE-UB32| 254. 220. 186. 152.)) +(|SYSTEM|::|C-PROCLAIM-CONSTANT| '|MD5|::|+MD5-MAGIC-D+| + '(|MD5|::|ASSEMBLE-UB32| 118. 84. 50. 16.)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|INITIAL-MD5-REGS|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|INITIAL-MD5-REGS| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '|COMMON-LISP|::|NIL|) + '(|COMMON-LISP|::|NIL| "Create the initial working state of an MD5 run." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|INITIAL-MD5-REGS|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|INITIAL-MD5-REGS| + (|COMMON-LISP|::|LET| + ((|MD5|::|REGS| + (|COMMON-LISP|::|MAKE-ARRAY| 4. :|ELEMENT-TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 32.)))) + (|COMMON-LISP|::|DECLARE| + (|COMMON-LISP|::|TYPE| |MD5|::|MD5-REGS| |MD5|::|REGS|)) + (|COMMON-LISP|::|SETF| (|MD5|::|MD5-REGS-A| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-A+| (|MD5|::|MD5-REGS-B| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-B+| (|MD5|::|MD5-REGS-C| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-C+| (|MD5|::|MD5-REGS-D| |MD5|::|REGS|) + |MD5|::|+MD5-MAGIC-D+|) + |MD5|::|REGS|)))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|UPDATE-MD5-BLOCK| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|MD5|::|REGS| |COMMON-LISP|::|BLOCK|))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|FILL-BLOCK| |MD5|::|FILL-BLOCK-UB8| + |MD5|::|FILL-BLOCK-CHAR|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|FILL-BLOCK-UB8| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#1=(|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|)) + '(#1# + "Convert a complete 64 (unsigned-byte 8) input vector segment\n +starting from offset into the given 16 word MD5 block." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|FILL-BLOCK-UB8|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777151.) + |MD5|::|OFFSET|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|SIMPLE-ARRAY| |MD5|::|UB32| (16.)) + |COMMON-LISP|::|BLOCK|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + |MD5|::|BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|FILL-BLOCK-UB8| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|I| |MD5|::|OF-TYPE| + (|COMMON-LISP|::|INTEGER| 0. 16.) |MD5|::|FROM| 0. |MD5|::|FOR| |MD5|::|J| + |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777215.) |MD5|::|FROM| + |MD5|::|OFFSET| |MD5|::|TO| (|COMMON-LISP|::|+| |MD5|::|OFFSET| 63.) + |MD5|::|BY| 4. |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |COMMON-LISP|::|BLOCK| |MD5|::|I|) + (|MD5|::|ASSEMBLE-UB32| + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| |MD5|::|J|) + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 1.)) + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 2.)) + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 3.)))))))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|FILL-BLOCK-CHAR| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#1=(|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|)) + '(#1# + "Convert a complete 64 character input string segment starting from\n +offset into the given 16 word MD5 block." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|FILL-BLOCK-CHAR|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777151.) + |MD5|::|OFFSET|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|SIMPLE-ARRAY| |MD5|::|UB32| (16.)) + |COMMON-LISP|::|BLOCK|) + (|COMMON-LISP|::|TYPE| |COMMON-LISP|::|SIMPLE-STRING| |MD5|::|BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|FILL-BLOCK-CHAR| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|I| |MD5|::|OF-TYPE| + (|COMMON-LISP|::|INTEGER| 0. 16.) |MD5|::|FROM| 0. |MD5|::|FOR| |MD5|::|J| + |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777215.) |MD5|::|FROM| + |MD5|::|OFFSET| |MD5|::|TO| (|COMMON-LISP|::|+| |MD5|::|OFFSET| 63.) + |MD5|::|BY| 4. |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |COMMON-LISP|::|BLOCK| |MD5|::|I|) + (|MD5|::|ASSEMBLE-UB32| + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| |MD5|::|J|)) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 1.))) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 2.))) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| |MD5|::|BUFFER| + (|COMMON-LISP|::|+| |MD5|::|J| 3.))))))))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|FILL-BLOCK| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#1=(|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| |MD5|::|OFFSET|)) + '(#1# + "Convert a complete 64 byte input vector segment into the given 16\n +word MD5 block. This currently works on (unsigned-byte 8) and\n +character simple-arrays, via the functions `fill-block-ub8' and\n +`fill-block-char' respectively." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|FILL-BLOCK|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 16777151.) + |MD5|::|OFFSET|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|SIMPLE-ARRAY| |MD5|::|UB32| (16.)) + |COMMON-LISP|::|BLOCK|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |COMMON-LISP|::|*| (|COMMON-LISP|::|*|)) + |MD5|::|BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.))) + (|COMMON-LISP|::|BLOCK| |MD5|::|FILL-BLOCK| + (|COMMON-LISP|::|ETYPECASE| |MD5|::|BUFFER| + ((|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + (|MD5|::|FILL-BLOCK-UB8| |COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| + |MD5|::|OFFSET|)) + (|COMMON-LISP|::|SIMPLE-STRING| + (|MD5|::|FILL-BLOCK-CHAR| |COMMON-LISP|::|BLOCK| |MD5|::|BUFFER| + |MD5|::|OFFSET|)))))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5REGS-DIGEST|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5REGS-DIGEST| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|MD5|::|REGS|)) + '(#1# + "Create the final 16 byte message-digest from the MD5 working state\n +in regs. Returns a (simple-array (unsigned-byte 8) (16))." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5REGS-DIGEST|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.)) + (|COMMON-LISP|::|TYPE| |MD5|::|MD5-REGS| |MD5|::|REGS|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5REGS-DIGEST| + (|COMMON-LISP|::|LET| + ((|MD5|::|RESULT| + (|COMMON-LISP|::|MAKE-ARRAY| 16. :|ELEMENT-TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 8.)))) + (|COMMON-LISP|::|DECLARE| + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (16.)) + |MD5|::|RESULT|)) + (|COMMON-LISP|::|MACROLET| + ((|MD5|::|FROB| (|MD5|::|REG| |MD5|::|OFFSET|) + (|COMMON-LISP|::|LET| ((|MD5|::|VAR| (|COMMON-LISP|::|GENSYM|))) + `(|COMMON-LISP|::|LET| ((,|MD5|::|VAR| ,|MD5|::|REG|)) + (|COMMON-LISP|::|DECLARE| + (|COMMON-LISP|::|TYPE| |MD5|::|UB32| ,|MD5|::|VAR|)) + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| ,|MD5|::|OFFSET|) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 0.) ,|MD5|::|VAR|) + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| + ,(|COMMON-LISP|::|+| |MD5|::|OFFSET| 1.)) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 8.) ,|MD5|::|VAR|) + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| + ,(|COMMON-LISP|::|+| |MD5|::|OFFSET| 2.)) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 16.) ,|MD5|::|VAR|) + (|COMMON-LISP|::|AREF| |MD5|::|RESULT| + ,(|COMMON-LISP|::|+| |MD5|::|OFFSET| 3.)) + (|COMMON-LISP|::|LDB| (|COMMON-LISP|::|BYTE| 8. 24.) + ,|MD5|::|VAR|)))))) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-A| |MD5|::|REGS|) 0.) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-B| |MD5|::|REGS|) 4.) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-C| |MD5|::|REGS|) 8.) + (|MD5|::|FROB| (|MD5|::|MD5-REGS-D| |MD5|::|REGS|) 12.)) + |MD5|::|RESULT|)))) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|LET| + ((#1=#:|G46629| + (|COMMON-LISP|::|CONS| '|MD5|::|MD5-STATE| + (|CLOS|::|CLASS-NAMES| + (|COMMON-LISP|::|GET| '|COMMON-LISP|::|STRUCTURE-OBJECT| + '|CLOS|::|CLOSCLASS|)))) + (#2=#:|G46630| + (|COMMON-LISP|::|FUNCTION| |MD5|::|DEFAULT-REGS| + (|COMMON-LISP|::|LAMBDA| |COMMON-LISP|::|NIL| + #3=(|MD5|::|INITIAL-MD5-REGS|)))) + (#4=#:|G46631| + (|COMMON-LISP|::|FUNCTION| |MD5|::|DEFAULT-BLOCK| + (|COMMON-LISP|::|LAMBDA| |COMMON-LISP|::|NIL| + #5=(|COMMON-LISP|::|MAKE-ARRAY| 16. :|ELEMENT-TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 32.))))) + (#6=#:|G46632| + (|COMMON-LISP|::|FUNCTION| |MD5|::|DEFAULT-BUFFER| + (|COMMON-LISP|::|LAMBDA| |COMMON-LISP|::|NIL| + #7=(|COMMON-LISP|::|MAKE-ARRAY| 64. :|ELEMENT-TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 8.)))))) + (|SYSTEM|::|STRUCTURE-UNDEFINE-ACCESSORIES| '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|REMPROP| '|MD5|::|MD5-STATE| + '|SYSTEM|::|DEFSTRUCT-DESCRIPTION|) + (|CLOS|::|DEFINE-STRUCTURE-CLASS| '|MD5|::|MD5-STATE| #1# + '|COMMON-LISP|::|NIL| '(|MD5|::|MAKE-MD5-STATE|) '|MD5|::|COPY-MD5-STATE| + '|MD5|::|MD5-STATE-P| + (|COMMON-LISP|::|LIST| + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|REGS| + :|INITARGS| '#8=(:|REGS|) :|TYPE| '|MD5|::|MD5-REGS| :|ALLOCATION| + ':|INSTANCE| #9='|CLOS|::|INHERITABLE-INITER| + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#3# #2#) + #10='|CLOS|::|INHERITABLE-DOC| '(|COMMON-LISP|::|NIL|) + #11='|CLOS|::|LOCATION| '1. #12='|CLOS|::|READONLY| '|COMMON-LISP|::|T|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|AMOUNT| + :|INITARGS| '#13=(:|AMOUNT|) :|TYPE| + '#14=(|COMMON-LISP|::|INTEGER| 0. |COMMON-LISP|::|*|) :|ALLOCATION| + ':|INSTANCE| #9# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '0. + #15=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| 0.)) + #10# '(|COMMON-LISP|::|NIL|) #11# '2. #12# '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|COMMON-LISP|::|BLOCK| :|INITARGS| '#16=(:|BLOCK|) :|TYPE| + '#17=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.) + (16.)) + :|ALLOCATION| ':|INSTANCE| #9# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#5# #4#) #10# + '(|COMMON-LISP|::|NIL|) #11# '3. #12# '|COMMON-LISP|::|T|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|BUFFER| + :|INITARGS| '#18=(:|BUFFER|) :|TYPE| + '#19=(|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (64.)) + :|ALLOCATION| ':|INSTANCE| #9# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#7# #6#) #10# + '(|COMMON-LISP|::|NIL|) #11# '4. #12# '|COMMON-LISP|::|T|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|MD5|::|BUFFER-INDEX| :|INITARGS| '#20=(:|BUFFER-INDEX|) :|TYPE| + '#21=(|COMMON-LISP|::|INTEGER| 0. 63.) :|ALLOCATION| ':|INSTANCE| #9# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '0. + #22=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| 0.)) + #10# '(|COMMON-LISP|::|NIL|) #11# '5. #12# '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|MD5|::|FINALIZED-P| :|INITARGS| '#23=(:|FINALIZED-P|) :|TYPE| + '|COMMON-LISP|::|T| :|ALLOCATION| ':|INSTANCE| #9# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #24=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|)) + #10# '(|COMMON-LISP|::|NIL|) #11# '6. #12# '|COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|LIST| + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|REGS| + :|INITARGS| '#8# :|TYPE| '|MD5|::|MD5-REGS| :|ALLOCATION| ':|INSTANCE| + #25='|CLOS|::|INHERITABLE-INITER| + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#3# #2#) + #26='|CLOS|::|INHERITABLE-DOC| '(|COMMON-LISP|::|NIL|) :|READERS| + '(|MD5|::|MD5-STATE-REGS|) :|WRITERS| '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|AMOUNT| + :|INITARGS| '#13# :|TYPE| '#14# :|ALLOCATION| ':|INSTANCE| #25# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '0. #15#) #26# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|MD5|::|MD5-STATE-AMOUNT|) :|WRITERS| + '((|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|COMMON-LISP|::|BLOCK| :|INITARGS| '#16# :|TYPE| '#17# :|ALLOCATION| + ':|INSTANCE| #25# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#5# #4#) #26# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|MD5|::|MD5-STATE-BLOCK|) :|WRITERS| + '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|BUFFER| + :|INITARGS| '#18# :|TYPE| '#19# :|ALLOCATION| ':|INSTANCE| #25# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#7# #6#) #26# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|MD5|::|MD5-STATE-BUFFER|) :|WRITERS| + '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|MD5|::|BUFFER-INDEX| :|INITARGS| '#20# :|TYPE| '#21# :|ALLOCATION| + ':|INSTANCE| #25# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '0. #22#) #26# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|MD5|::|MD5-STATE-BUFFER-INDEX|) + :|WRITERS| '((|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|MD5|::|FINALIZED-P| + :|INITARGS| '#23# :|TYPE| '|COMMON-LISP|::|T| :|ALLOCATION| ':|INSTANCE| + #25# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #24#) + #26# '(|COMMON-LISP|::|NIL|) :|READERS| '(|MD5|::|MD5-STATE-FINALIZED-P|) + :|WRITERS| '((|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|))))) + (|COMMON-LISP|::|DEFUN| |MD5|::|MAKE-MD5-STATE| + (|COMMON-LISP|::|&AUX| (|MD5|::|REGS| #3#) (|MD5|::|AMOUNT| 0.) + (|COMMON-LISP|::|BLOCK| #5#) (|MD5|::|BUFFER| #7#) + (|MD5|::|BUFFER-INDEX| 0.) (|MD5|::|FINALIZED-P| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|LET| + ((|SYSTEM|::|OBJECT| (|SYSTEM|::|%MAKE-STRUCTURE| #1# 7.))) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 1.) + (|COMMON-LISP|::|THE| |MD5|::|MD5-REGS| |MD5|::|REGS|)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 2.) + (|COMMON-LISP|::|THE| #14# |MD5|::|AMOUNT|)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 3.) + (|COMMON-LISP|::|THE| #17# |COMMON-LISP|::|BLOCK|)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 4.) + (|COMMON-LISP|::|THE| #19# |MD5|::|BUFFER|)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 5.) + (|COMMON-LISP|::|THE| #21# |MD5|::|BUFFER-INDEX|)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 6.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|T| |MD5|::|FINALIZED-P|)) + |SYSTEM|::|OBJECT|))) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-P|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-P| (|SYSTEM|::|OBJECT|) + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|COPY-MD5-STATE|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|COPY-MD5-STATE| (|COMMON-LISP|::|STRUCTURE|) + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-REGS| (|MD5|::|MD5-STATE|) + |MD5|::|MD5-REGS|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-REGS|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-REGS| #27=(|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|THE| |MD5|::|MD5-REGS| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 1.))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-REGS| #28='|SYSTEM|::|DEFSTRUCT-READER| + '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-AMOUNT| (|MD5|::|MD5-STATE|) + #14#)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-AMOUNT|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-AMOUNT| #27# + (|COMMON-LISP|::|THE| #14# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 2.))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-AMOUNT| #28# '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BLOCK| (|MD5|::|MD5-STATE|) + #17#)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BLOCK|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-BLOCK| #27# + (|COMMON-LISP|::|THE| #17# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 3.))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-BLOCK| #28# '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BUFFER| (|MD5|::|MD5-STATE|) + #19#)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BUFFER|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-BUFFER| #27# + (|COMMON-LISP|::|THE| #19# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 4.))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-BUFFER| #28# '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|MD5|::|MD5-STATE|) #21#)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BUFFER-INDEX|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-BUFFER-INDEX| #27# + (|COMMON-LISP|::|THE| #21# + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 5.))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-BUFFER-INDEX| #28# '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-FINALIZED-P| + (|MD5|::|MD5-STATE|) |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-FINALIZED-P|)) + (|COMMON-LISP|::|DEFUN| |MD5|::|MD5-STATE-FINALIZED-P| #27# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|T| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 6.))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-FINALIZED-P| #28# '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|) + (#14# |MD5|::|MD5-STATE|) #14#)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|) + #29=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| #14# . #30=(|SYSTEM|::|VALUE|)))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-AMOUNT| #31='|SYSTEM|::|DEFSTRUCT-WRITER| + '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|) + (#21# |MD5|::|MD5-STATE|) #21#)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|))) + (|COMMON-LISP|::|DEFUN| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|) #29# + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 5. + (|COMMON-LISP|::|THE| #21# . #30#))) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-BUFFER-INDEX| #31# '|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|) + (|COMMON-LISP|::|T| |MD5|::|MD5-STATE|) |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|) + #29# + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 6. + |SYSTEM|::|VALUE|)) + (|SYSTEM|::|%PUT| '|MD5|::|MD5-STATE-FINALIZED-P| #31# '|MD5|::|MD5-STATE|) + (|SYSTEM|::|%SET-DOCUMENTATION| '|MD5|::|MD5-STATE| '|COMMON-LISP|::|TYPE| + |COMMON-LISP|::|NIL|) + (|CLOS|::|DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD| '|MD5|::|MD5-STATE|) + '|MD5|::|MD5-STATE|) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MAKE-MD5-STATE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&AUX| (|MD5|::|REGS| (|MD5|::|INITIAL-MD5-REGS|)) + (|MD5|::|AMOUNT| 0.) + (|COMMON-LISP|::|BLOCK| + (|COMMON-LISP|::|MAKE-ARRAY| 16. :|ELEMENT-TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 32.))) + (|MD5|::|BUFFER| + (|COMMON-LISP|::|MAKE-ARRAY| 64. :|ELEMENT-TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 8.))) + (|MD5|::|BUFFER-INDEX| 0.) (|MD5|::|FINALIZED-P| |COMMON-LISP|::|NIL|)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-P|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-P| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-P|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-P| + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT|)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|COPY-MD5-STATE|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|COPY-MD5-STATE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|COMMON-LISP|::|STRUCTURE|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|COPY-MD5-STATE|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|COPY-MD5-STATE| + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|)))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-REGS| (|MD5|::|MD5-STATE|) + |MD5|::|MD5-REGS|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-REGS|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-REGS| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-REGS|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-REGS| + (|COMMON-LISP|::|THE| |MD5|::|MD5-REGS| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 1.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-AMOUNT| (|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|INTEGER| 0. |COMMON-LISP|::|*|))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-AMOUNT|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-AMOUNT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-AMOUNT|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-AMOUNT| + (|COMMON-LISP|::|THE| (|COMMON-LISP|::|INTEGER| 0. |COMMON-LISP|::|*|) + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 2.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BLOCK| (|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.) (16.)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BLOCK|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-BLOCK| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-BLOCK|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BLOCK| + (|COMMON-LISP|::|THE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.) (16.)) + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 3.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BUFFER| (|MD5|::|MD5-STATE|) + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) (64.)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BUFFER|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-BUFFER| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-BUFFER|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BUFFER| + (|COMMON-LISP|::|THE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) (64.)) + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 4.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|MD5|::|MD5-STATE|) (|COMMON-LISP|::|INTEGER| 0. 63.))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-BUFFER-INDEX|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-BUFFER-INDEX| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-BUFFER-INDEX|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|COMMON-LISP|::|THE| (|COMMON-LISP|::|INTEGER| 0. 63.) + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 5.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |MD5|::|MD5-STATE-FINALIZED-P| + (|MD5|::|MD5-STATE|) |COMMON-LISP|::|T|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| |MD5|::|MD5-STATE-FINALIZED-P|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STATE-FINALIZED-P| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |MD5|::|MD5-STATE-FINALIZED-P|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-FINALIZED-P| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|T| + (|SYSTEM|::|%STRUCTURE-REF| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 6.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|) + (#1=(|COMMON-LISP|::|INTEGER| 0. |COMMON-LISP|::|*|) |MD5|::|MD5-STATE|) + #1#)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-AMOUNT|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-AMOUNT| + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| (|COMMON-LISP|::|INTEGER| 0. |COMMON-LISP|::|*|) + |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|) + (#1=(|COMMON-LISP|::|INTEGER| 0. 63.) |MD5|::|MD5-STATE|) #1#)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|))) +(|SYSTEM|::|C-DEFUN| + '#1=(|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-BUFFER-INDEX|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-BUFFER-INDEX| + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 5. + (|COMMON-LISP|::|THE| (|COMMON-LISP|::|INTEGER| 0. 63.) + |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|) + (|COMMON-LISP|::|T| |MD5|::|MD5-STATE|) |COMMON-LISP|::|T|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |MD5|::|MD5-STATE-FINALIZED-P|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |MD5|::|MD5-STATE-FINALIZED-P| + (|SYSTEM|::|%STRUCTURE-STORE| '|MD5|::|MD5-STATE| |SYSTEM|::|OBJECT| 6. + |SYSTEM|::|VALUE|)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |MD5|::|COPY-TO-BUFFER|)) +(|SYSTEM|::|C-DEFUN| '|MD5|::|COPY-TO-BUFFER| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#1=(|MD5|::|FROM| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT| + |MD5|::|BUFFER| |MD5|::|BUFFER-OFFSET|)) + '(#1# + "Copy a partial segment from input vector from starting at\n +from-offset and copying count elements into the 64 byte buffer\n +starting at buffer-offset." + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |MD5|::|COPY-TO-BUFFER|) + (|COMMON-LISP|::|OPTIMIZE| (|COMMON-LISP|::|SPEED| 3.) + (|COMMON-LISP|::|SAFETY| 0.) (|COMMON-LISP|::|SPACE| 0.) + (|COMMON-LISP|::|DEBUG| 0.)) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|UNSIGNED-BYTE| 29.) + |MD5|::|FROM-OFFSET|) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|INTEGER| 0. 63.) + |COMMON-LISP|::|COUNT| |MD5|::|BUFFER-OFFSET|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| |COMMON-LISP|::|*| (|COMMON-LISP|::|*|)) + |MD5|::|FROM|) + (|COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) (64.)) + |MD5|::|BUFFER|)) + (|COMMON-LISP|::|BLOCK| |MD5|::|COPY-TO-BUFFER| + (|COMMON-LISP|::|ETYPECASE| |MD5|::|FROM| + (|COMMON-LISP|::|SIMPLE-STRING| + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|BUFFER-INDEX| + |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 64.) |MD5|::|FROM| + |MD5|::|BUFFER-OFFSET| |MD5|::|FOR| |MD5|::|FROM-INDEX| |MD5|::|OF-TYPE| + |COMMON-LISP|::|FIXNUM| |MD5|::|FROM| |MD5|::|FROM-OFFSET| + |MD5|::|BELOW| + (|COMMON-LISP|::|+| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT|) + |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| |MD5|::|BUFFER-INDEX|) + (|COMMON-LISP|::|CHAR-CODE| + (|COMMON-LISP|::|SCHAR| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| |MD5|::|FROM|) + |MD5|::|FROM-INDEX|))))) + ((|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + (|COMMON-LISP|::|LOOP| |MD5|::|FOR| |MD5|::|BUFFER-INDEX| + |MD5|::|OF-TYPE| (|COMMON-LISP|::|INTEGER| 0. 64.) |MD5|::|FROM| + |MD5|::|BUFFER-OFFSET| |MD5|::|FOR| |MD5|::|FROM-INDEX| |MD5|::|OF-TYPE| + |COMMON-LISP|::|FIXNUM| |MD5|::|FROM| |MD5|::|FROM-OFFSET| + |MD5|::|BELOW| + (|COMMON-LISP|::|+| |MD5|::|FROM-OFFSET| |COMMON-LISP|::|COUNT|) + |COMMON-LISP|::|DO| + (|COMMON-LISP|::|SETF| + (|COMMON-LISP|::|AREF| |MD5|::|BUFFER| |MD5|::|BUFFER-INDEX|) + (|COMMON-LISP|::|AREF| + (|COMMON-LISP|::|THE| + (|COMMON-LISP|::|SIMPLE-ARRAY| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + (|COMMON-LISP|::|*|)) + |MD5|::|FROM|) + |MD5|::|FROM-INDEX|)))))))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|UPDATE-MD5-STATE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|MD5|::|STATE| |COMMON-LISP|::|SEQUENCE| |COMMON-LISP|::|&KEY| + (|MD5|::|START| 0.) + (|MD5|::|END| (|COMMON-LISP|::|LENGTH| |COMMON-LISP|::|SEQUENCE|))))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|FINALIZE-MD5-STATE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|MD5|::|STATE|))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5SUM-SEQUENCE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|SEQUENCE| |COMMON-LISP|::|&KEY| (|MD5|::|START| 0.) + |MD5|::|END|))) +(|COMMON-LISP|::|DEFCONSTANT| |MD5|::|+BUFFER-SIZE+| + (|COMMON-LISP|::|*| 128. 1024.) + "Size of internal buffer to use for md5sum-stream and md5sum-file\n +operations. This should be a multiple of 64, the MD5 block size.") +(|SYSTEM|::|C-PROCLAIM-CONSTANT| '|MD5|::|+BUFFER-SIZE+| + '(|COMMON-LISP|::|*| 128. 1024.)) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|SYSTEM|::|%PUT| '|MD5|::|BUFFER-INDEX| '|SYSTEM|::|DEFTYPE-EXPANDER| + (|COMMON-LISP|::|FUNCTION| #:|DEFTYPE-BUFFER-INDEX| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::||) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 1. + 1.)) + (|SYSTEM|::|TYPE-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|BLOCK| |MD5|::|BUFFER-INDEX| + `(|COMMON-LISP|::|INTEGER| 0. ,|MD5|::|+BUFFER-SIZE+|))))))) + (|SYSTEM|::|%SET-DOCUMENTATION| '|MD5|::|BUFFER-INDEX| '|COMMON-LISP|::|TYPE| + '|COMMON-LISP|::|NIL|) + '|MD5|::|BUFFER-INDEX|) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5SUM-STREAM| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|COMMON-LISP|::|STREAM|))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5SUM-FILE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|COMMON-LISP|::|PATHNAME|))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5-STRING| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|MD5|::|MD5-DIGEST|))) +(|SYSTEM|::|C-DEFUN| '|MD5|::|MD5| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|COMMON-LISP|::|SEQUENCE|))) Added: clfswm/contrib/server/md5.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/md5.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,750 @@ +;;;; This file implements The MD5 Message-Digest Algorithm, as defined in +;;;; RFC 1321 by R. Rivest, published April 1992. +;;;; +;;;; It was written by Pierre R. Mai, with copious input from the +;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and +;;;; has been placed into the public domain. +;;;; +;;;; While the implementation should work on all conforming Common +;;;; Lisp implementations, it has only been optimized for CMU CL, +;;;; where it achieved comparable performance to the standard md5sum +;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc +;;;; hardware). +;;;; +;;;; Since the implementation makes heavy use of arithmetic on +;;;; (unsigned-byte 32) numbers, acceptable performance is likely only +;;;; on CL implementations that support unboxed arithmetic on such +;;;; numbers in some form. For other CL implementations a 16bit +;;;; implementation of MD5 is probably more suitable. +;;;; +;;;; The code implements correct operation for files of unbounded size +;;;; as is, at the cost of having to do a single generic integer +;;;; addition for each call to update-md5-state. If you call +;;;; update-md5-state frequently with little data, this can pose a +;;;; performance problem. If you can live with a size restriction of +;;;; 512 MB, then you can enable fast fixnum arithmetic by putting +;;;; :md5-small-length onto *features* prior to compiling this file. +;;;; +;;;; Testing code can be compiled by including :md5-testing on +;;;; *features* prior to compilation. In that case evaluating +;;;; (md5::test-rfc1321) will run all the test-cases present in +;;;; Appendix A.5 of RFC 1321 and report on the results. +;;;; Evaluating (md5::test-other) will run further test-cases +;;;; gathered by the author to cover regressions, etc. +;;;; +;;;; This software is "as is", and has no warranty of any kind. The +;;;; authors assume no responsibility for the consequences of any use +;;;; of this software. + +(defpackage #:md5 (:use #:cl) + (:export + ;; Low-Level types and functions + #:md5-regs #:initial-md5-regs #:md5regs-digest + #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char + ;; Mid-Level types and functions + #:md5-state #:md5-state-p #:make-md5-state + #:update-md5-state #:finalize-md5-state + ;; High-Level functions on sequences, streams and files + #:md5sum-sequence #:md5sum-stream #:md5sum-file + ;; Very High level functions + #:md5)) + +(in-package #:md5) + +#+cmu +(eval-when (:compile-toplevel) + (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) + (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) + +#+cmu +(eval-when (:compile-toplevel :execute) + (defparameter *old-features* *features*) + (pushnew (c:backend-byte-order c:*target-backend*) *features*)) + +;;; Section 2: Basic Datatypes + +#-lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (deftype ub32 () + "Corresponds to the 32bit quantity word of the MD5 Spec" + `(unsigned-byte 32))) + +#+lispworks +(deftype ub32 () + "Corresponds to the 32bit quantity word of the MD5 Spec" + `(unsigned-byte 32)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro assemble-ub32 (a b c d) + "Assemble an ub32 value from the given (unsigned-byte 8) values, +where a is the intended low-order byte and d the high-order byte." + `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) + +;;; Section 3.4: Auxilliary functions + +(declaim (inline f g h i) + (ftype (function (ub32 ub32 ub32) ub32) f g h i)) + +(defun f (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-or (kernel:32bit-logical-and x y) + (kernel:32bit-logical-andc1 x z)) + #-cmu + (logior (logand x y) (logandc1 x z))) + +(defun g (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-or (kernel:32bit-logical-and x z) + (kernel:32bit-logical-andc2 y z)) + #-cmu + (logior (logand x z) (logandc2 y z))) + +(defun h (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) + #-cmu + (logxor x y z)) + +(defun i (x y z) + (declare (type ub32 x y z) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) + #-cmu + (ldb (byte 32 0) (logxor y (logorc2 x z)))) + +(declaim (inline mod32+) + (ftype (function (ub32 ub32) ub32) mod32+)) +(defun mod32+ (a b) + (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (ldb (byte 32 0) (+ a b))) + +#+cmu +(define-compiler-macro mod32+ (a b) + `(ext:truly-the ub32 (+ ,a ,b))) + +(declaim (inline rol32) + (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) +(defun rol32 (a s) + (declare (type ub32 a) (type (unsigned-byte 5) s) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + #+cmu + (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) + #+big-endian (kernel:shift-towards-start a s) + (ash a (- s 32))) + #-cmu + (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) + +;;; Section 3.4: Table T + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *t* (make-array 64 :element-type 'ub32 + :initial-contents + (loop for i from 1 to 64 + collect + (truncate + (* 4294967296 + (abs (sin (float i 0.0d0))))))))) + +;;; Section 3.4: Helper Macro for single round definitions + +(defmacro with-md5-round ((op block) &rest clauses) + (loop for (a b c d k s i) in clauses + collect + `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) + (mod32+ (aref ,block ,k) + ,(aref *t* (1- i)))) + ,s))) + into result + finally + (return `(progn , at result)))) + +;;; Section 3.3: (Initial) MD5 Working Set + +(deftype md5-regs () + "The working state of the MD5 algorithm, which contains the 4 32-bit +registers A, B, C and D." + `(simple-array (unsigned-byte 32) (4))) + +(defmacro md5-regs-a (regs) + `(aref ,regs 0)) + +(defmacro md5-regs-b (regs) + `(aref ,regs 1)) + +(defmacro md5-regs-c (regs) + `(aref ,regs 2)) + +(defmacro md5-regs-d (regs) + `(aref ,regs 3)) + +(defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67) + "Initial value of Register A of the MD5 working state.") +(defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef) + "Initial value of Register B of the MD5 working state.") +(defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98) + "Initial value of Register C of the MD5 working state.") +(defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10) + "Initial value of Register D of the MD5 working state.") + +(declaim (inline initial-md5-regs)) +(defun initial-md5-regs () + "Create the initial working state of an MD5 run." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) + (declare (type md5-regs regs)) + (setf (md5-regs-a regs) +md5-magic-a+ + (md5-regs-b regs) +md5-magic-b+ + (md5-regs-c regs) +md5-magic-c+ + (md5-regs-d regs) +md5-magic-d+) + regs)) + +;;; Section 3.4: Operation on 16-Word Blocks + +(defun update-md5-block (regs block) + "This is the core part of the MD5 algorithm. It takes a complete 16 +word block of input, and updates the working state in A, B, C, and D +accordingly." + (declare (type md5-regs regs) + (type (simple-array ub32 (16)) block) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (let ((A (md5-regs-a regs)) (B (md5-regs-b regs)) + (C (md5-regs-c regs)) (D (md5-regs-d regs))) + (declare (type ub32 A B C D)) + ;; Round 1 + (with-md5-round (f block) + (A B C D 0 7 1)(D A B C 1 12 2)(C D A B 2 17 3)(B C D A 3 22 4) + (A B C D 4 7 5)(D A B C 5 12 6)(C D A B 6 17 7)(B C D A 7 22 8) + (A B C D 8 7 9)(D A B C 9 12 10)(C D A B 10 17 11)(B C D A 11 22 12) + (A B C D 12 7 13)(D A B C 13 12 14)(C D A B 14 17 15)(B C D A 15 22 16)) + ;; Round 2 + (with-md5-round (g block) + (A B C D 1 5 17)(D A B C 6 9 18)(C D A B 11 14 19)(B C D A 0 20 20) + (A B C D 5 5 21)(D A B C 10 9 22)(C D A B 15 14 23)(B C D A 4 20 24) + (A B C D 9 5 25)(D A B C 14 9 26)(C D A B 3 14 27)(B C D A 8 20 28) + (A B C D 13 5 29)(D A B C 2 9 30)(C D A B 7 14 31)(B C D A 12 20 32)) + ;; Round 3 + (with-md5-round (h block) + (A B C D 5 4 33)(D A B C 8 11 34)(C D A B 11 16 35)(B C D A 14 23 36) + (A B C D 1 4 37)(D A B C 4 11 38)(C D A B 7 16 39)(B C D A 10 23 40) + (A B C D 13 4 41)(D A B C 0 11 42)(C D A B 3 16 43)(B C D A 6 23 44) + (A B C D 9 4 45)(D A B C 12 11 46)(C D A B 15 16 47)(B C D A 2 23 48)) + ;; Round 4 + (with-md5-round (i block) + (A B C D 0 6 49)(D A B C 7 10 50)(C D A B 14 15 51)(B C D A 5 21 52) + (A B C D 12 6 53)(D A B C 3 10 54)(C D A B 10 15 55)(B C D A 1 21 56) + (A B C D 8 6 57)(D A B C 15 10 58)(C D A B 6 15 59)(B C D A 13 21 60) + (A B C D 4 6 61)(D A B C 11 10 62)(C D A B 2 15 63)(B C D A 9 21 64)) + ;; Update and return + (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) A) + (md5-regs-b regs) (mod32+ (md5-regs-b regs) B) + (md5-regs-c regs) (mod32+ (md5-regs-c regs) C) + (md5-regs-d regs) (mod32+ (md5-regs-d regs) D)) + regs)) + +;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks + +(declaim (inline fill-block fill-block-ub8 fill-block-char)) + +(defun fill-block-ub8 (block buffer offset) + "Convert a complete 64 (unsigned-byte 8) input vector segment +starting from offset into the given 16 word MD5 block." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) +;; #+(and :cmu :little-endian) +;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) +;; buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) +;; block (* vm:vector-data-offset vm:word-bits) +;; (* 64 vm:byte-bits)) +;; #-(and :cmu :little-endian) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.most-positive-fixnum) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) + (assemble-ub32 (aref buffer j) + (aref buffer (+ j 1)) + (aref buffer (+ j 2)) + (aref buffer (+ j 3)))))) + +(defun fill-block-char (block buffer offset) + "Convert a complete 64 character input string segment starting from +offset into the given 16 word MD5 block." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type simple-string buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) +;; #+(and :cmu :little-endian) +;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) +;; buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) +;; block (* vm:vector-data-offset vm:word-bits) +;; (* 64 vm:byte-bits)) +;; #-(and :cmu :little-endian) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.most-positive-fixnum) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) + (assemble-ub32 (char-code (schar buffer j)) + (char-code (schar buffer (+ j 1))) + (char-code (schar buffer (+ j 2))) + (char-code (schar buffer (+ j 3))))))) + +(defun fill-block (block buffer offset) + "Convert a complete 64 byte input vector segment into the given 16 +word MD5 block. This currently works on (unsigned-byte 8) and +character simple-arrays, via the functions `fill-block-ub8' and +`fill-block-char' respectively." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type (simple-array * (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (etypecase buffer + ((simple-array (unsigned-byte 8) (*)) + (fill-block-ub8 block buffer offset)) + (simple-string + (fill-block-char block buffer offset)))) + +;;; Section 3.5: Message Digest Output + +(declaim (inline md5regs-digest)) +(defun md5regs-digest (regs) + "Create the final 16 byte message-digest from the MD5 working state +in regs. Returns a (simple-array (unsigned-byte 8) (16))." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) + (type md5-regs regs)) + (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (16)) result)) + (macrolet ((frob (reg offset) + (let ((var (gensym))) + `(let ((,var ,reg)) + (declare (type ub32 ,var)) + (setf + (aref result ,offset) (ldb (byte 8 0) ,var) + (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) + (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) + (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) + (frob (md5-regs-a regs) 0) + (frob (md5-regs-b regs) 4) + (frob (md5-regs-c regs) 8) + (frob (md5-regs-d regs) 12)) + result)) + +;;; Mid-Level Drivers + +(defstruct (md5-state + (:constructor make-md5-state ()) + (:copier)) + (regs (initial-md5-regs) :type md5-regs :read-only t) + (amount 0 :type + #-md5-small-length (integer 0 *) + #+md5-small-length (unsigned-byte 29)) + (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t + :type (simple-array (unsigned-byte 32) (16))) + (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t + :type (simple-array (unsigned-byte 8) (64))) + (buffer-index 0 :type (integer 0 63)) + (finalized-p nil)) + +(declaim (inline copy-to-buffer)) +(defun copy-to-buffer (from from-offset count buffer buffer-offset) + "Copy a partial segment from input vector from starting at +from-offset and copying count elements into the 64 byte buffer +starting at buffer-offset." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) + (type (unsigned-byte 29) from-offset) + (type (integer 0 63) count buffer-offset) + (type (simple-array * (*)) from) + (type (simple-array (unsigned-byte 8) (64)) buffer)) +;; #+cmu +;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) +;; from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) +;; buffer (+ (* vm:vector-data-offset vm:word-bits) +;; (* buffer-offset vm:byte-bits)) +;; (* count vm:byte-bits)) +;; #-cmu + (etypecase from + (simple-string + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (char-code (schar (the simple-string from) from-index))))) + ((simple-array (unsigned-byte 8) (*)) + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (aref (the (simple-array (unsigned-byte 8) (*)) from) + from-index)))))) + +(defun update-md5-state (state sequence &key (start 0) (end (length sequence))) + "Update the given md5-state from sequence, which is either a +simple-string or a simple-array with element-type (unsigned-byte 8), +bounded by start and end, which must be numeric bounding-indices." + (declare (type md5-state state) + (type (simple-array * (*)) sequence) + (type fixnum start end) + (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) + #+cmu + (ext:optimize-interface (safety 1) (debug 1))) + (let ((regs (md5-state-regs state)) + (block (md5-state-block state)) + (buffer (md5-state-buffer state))) + (declare (type md5-regs regs) + (type (simple-array (unsigned-byte 32) (16)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) + ;; Handle old rest + (unless (zerop (md5-state-buffer-index state)) + (let* ((buffer-index (md5-state-buffer-index state)) + (remainder (- 64 buffer-index)) + (length (- end start)) + (amount (min remainder length))) + (declare (type (integer 0 63) buffer-index remainder amount) + (type fixnum length)) + (copy-to-buffer sequence start amount buffer buffer-index) + (setf (md5-state-amount state) + #-md5-small-length (+ (md5-state-amount state) amount) + #+md5-small-length (the (unsigned-byte 29) + (+ (md5-state-amount state) amount))) + (setq start (the fixnum (+ start amount))) + (if (< length remainder) + (setf (md5-state-buffer-index state) + (the (integer 0 63) (+ buffer-index amount))) + (progn + (fill-block-ub8 block buffer 0) + (update-md5-block regs block) + (setf (md5-state-buffer-index state) 0))))) + ;; Leave when nothing to do + (when (>= start end) + (return-from update-md5-state state)) + ;; Handle main-part and new-rest + (etypecase sequence + ((simple-array (unsigned-byte 8) (*)) + (locally + (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) + (loop for offset of-type (unsigned-byte 29) from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-ub8 block sequence offset) + (update-md5-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (md5-state-buffer-index state) amount))))) + (simple-string + (locally + (declare (type simple-string sequence)) + (loop for offset of-type (unsigned-byte 29) from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-char block sequence offset) + (update-md5-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (md5-state-buffer-index state) amount)))))) + (setf (md5-state-amount state) + #-md5-small-length (+ (md5-state-amount state) + (the fixnum (- end start))) + #+md5-small-length (the (unsigned-byte 29) + (+ (md5-state-amount state) + (the fixnum (- end start))))) + state)) + +(defun finalize-md5-state (state) + "If the given md5-state has not already been finalized, finalize it, +by processing any remaining input in its buffer, with suitable padding +and appended bit-length, as specified by the MD5 standard. + +The resulting MD5 message-digest is returned as an array of sixteen +(unsigned-byte 8) values. Calling `update-md5-state' after a call to +`finalize-md5-state' results in unspecified behaviour." + (declare (type md5-state state) + (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) + #+cmu + (ext:optimize-interface (safety 1) (debug 1))) + (or (md5-state-finalized-p state) + (let ((regs (md5-state-regs state)) + (block (md5-state-block state)) + (buffer (md5-state-buffer state)) + (buffer-index (md5-state-buffer-index state)) + (total-length (* 8 (md5-state-amount state)))) + (declare (type md5-regs regs) + (type (integer 0 63) buffer-index) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer)) + ;; Add mandatory bit 1 padding + (setf (aref buffer buffer-index) #x80) + ;; Fill with 0 bit padding + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + (fill-block-ub8 block buffer 0) + ;; Flush block first if length wouldn't fit + (when (>= buffer-index 56) + (update-md5-block regs block) + ;; Create new fully 0 padded block + (loop for index of-type (integer 0 16) from 0 below 16 + do (setf (aref block index) #x00000000))) + ;; Add 64bit message bit length + (setf (aref block 14) (ldb (byte 32 0) total-length)) + #-md5-small-length + (setf (aref block 15) (ldb (byte 32 32) total-length)) + ;; Flush last block + (update-md5-block regs block) + ;; Done, remember digest for later calls + (setf (md5-state-finalized-p state) + (md5regs-digest regs))))) + +;;; High-Level Drivers + +(defun md5sum-sequence (sequence &key (start 0) end) + "Calculate the MD5 message-digest of data in sequence. On CMU CL +this works for all sequences whose element-type is supported by the +underlying MD5 routines, on other implementations it only works for 1d +simple-arrays with such element types." + (declare (optimize (speed 3) (space 0) (debug 0)) + (type vector sequence) (type fixnum start)) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + #+cmu + (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) + (update-md5-state state data :start real-start :end real-end)) + #-cmu + (let ((real-end (or end (length sequence)))) + (declare (type fixnum real-end)) + (update-md5-state state sequence :start start :end real-end)) + (finalize-md5-state state))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +buffer-size+ (* 128 1024) + "Size of internal buffer to use for md5sum-stream and md5sum-file +operations. This should be a multiple of 64, the MD5 block size.")) + +(deftype buffer-index () `(integer 0 ,+buffer-size+)) + +(defun md5sum-stream (stream) + "Calculate an MD5 message-digest of the contents of stream. Its +element-type has to be either (unsigned-byte 8) or character." + (declare (optimize (speed 3) (space 0) (debug 0))) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + (cond + ((equal (stream-element-type stream) '(unsigned-byte 8)) + (let ((buffer (make-array +buffer-size+ + :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) + buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + ((equal (stream-element-type stream) 'character) + (let ((buffer (make-string +buffer-size+))) + (declare (type (simple-string #.+buffer-size+) buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + (t + (error "Unsupported stream element-type ~S for stream ~S." + (stream-element-type stream) stream))))) + +(defun md5sum-file (pathname) + "Calculate the MD5 message-digest of the file specified by pathname." + (declare (optimize (speed 3) (space 0) (debug 0))) + (with-open-file (stream pathname :element-type '(unsigned-byte 8)) + (md5sum-stream stream))) + + + +(defun md5-string (md5-digest) + (format nil "~(~{~2,'0X~}~)" + (map 'list #'identity md5-digest))) + + +(defun md5 (sequence) + (md5-string (md5sum-sequence sequence))) + + + +#+md5-testing +(defconstant +rfc1321-testsuite+ + '(("" . "d41d8cd98f00b204e9800998ecf8427e") + ("a" ."0cc175b9c0f1b6a831c399e269772661") + ("abc" . "900150983cd24fb0d6963f7d28e17f72") + ("message digest" . "f96b697d7cb7938d525a2f31aaf161d0") + ("abcdefghijklmnopqrstuvwxyz" . "c3fcd3d76192e4007dfb496cca67e13b") + ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" . + "d174ab98d277d9f5a5611c2c9f419d9f") + ("12345678901234567890123456789012345678901234567890123456789012345678901234567890" . + "57edf4a22be3c955ac49da2e2107b67a")) + "AList of test input strings and stringified message-digests +according to the test suite in Appendix A.5 of RFC 1321") + +#+md5-testing +(defconstant +other-testsuite+ + '(;; From padding bug report by Edi Weitz + ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . + "d734945e5930bb28859ccd13c830358b") + ;; Test padding for strings from 0 to 69*8 bits in size. + ("" . "d41d8cd98f00b204e9800998ecf8427e") + ("a" . "0cc175b9c0f1b6a831c399e269772661") + ("aa" . "4124bc0a9335c27f086f24ba207a4912") + ("aaa" . "47bce5c74f589f4867dbd57e9ca9f808") + ("aaaa" . "74b87337454200d4d33f80c4663dc5e5") + ("aaaaa" . "594f803b380a41396ed63dca39503542") + ("aaaaaa" . "0b4e7a0e5fe84ad35fb5f95b9ceeac79") + ("aaaaaaa" . "5d793fc5b00a2348c3fb9ab59e5ca98a") + ("aaaaaaaa" . "3dbe00a167653a1aaee01d93e77e730e") + ("aaaaaaaaa" . "552e6a97297c53e592208cf97fbb3b60") + ("aaaaaaaaaa" . "e09c80c42fda55f9d992e59ca6b3307d") + ("aaaaaaaaaaa" . "d57f21e6a273781dbf8b7657940f3b03") + ("aaaaaaaaaaaa" . "45e4812014d83dde5666ebdf5a8ed1ed") + ("aaaaaaaaaaaaa" . "c162de19c4c3731ca3428769d0cd593d") + ("aaaaaaaaaaaaaa" . "451599a5f9afa91a0f2097040a796f3d") + ("aaaaaaaaaaaaaaa" . "12f9cf6998d52dbe773b06f848bb3608") + ("aaaaaaaaaaaaaaaa" . "23ca472302f49b3ea5592b146a312da0") + ("aaaaaaaaaaaaaaaaa" . "88e42e96cc71151b6e1938a1699b0a27") + ("aaaaaaaaaaaaaaaaaa" . "2c60c24e7087e18e45055a33f9a5be91") + ("aaaaaaaaaaaaaaaaaaa" . "639d76897485360b3147e66e0a8a3d6c") + ("aaaaaaaaaaaaaaaaaaaa" . "22d42eb002cefa81e9ad604ea57bc01d") + ("aaaaaaaaaaaaaaaaaaaaa" . "bd049f221af82804c5a2826809337c9b") + ("aaaaaaaaaaaaaaaaaaaaaa" . "ff49cfac3968dbce26ebe7d4823e58bd") + ("aaaaaaaaaaaaaaaaaaaaaaa" . "d95dbfee231e34cccb8c04444412ed7d") + ("aaaaaaaaaaaaaaaaaaaaaaaa" . "40edae4bad0e5bf6d6c2dc5615a86afb") + ("aaaaaaaaaaaaaaaaaaaaaaaaa" . "a5a8bfa3962f49330227955e24a2e67c") + ("aaaaaaaaaaaaaaaaaaaaaaaaaa" . "ae791f19bdf77357ff10bb6b0e97e121") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" . "aaab9c59a88bf0bdfcb170546c5459d6") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b0f0545856af1a340acdedce23c54b97") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "f7ce3d7d44f3342107d884bfa90c966a") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "59e794d45697b360e18ba972bada0123") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0845db57c200be6052466f87b2198a") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "5eca9bd3eb07c006cd43ae48dfde7fd3") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b4f13cb081e412f44e99742cb128a1a5") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c660346451b8cf91ef50f4634458d41") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "11db24dc3f6c2145701db08625dd6d76") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "80dad3aad8584778352c68ab06250327") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "1227fe415e79db47285cb2689c93963f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "8e084f489f1bdf08c39f98ff6447ce6d") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "08b2f2b0864bac1ba1585043362cbec9") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4697843037d962f62a5a429e611e0f5f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "10c4da18575c092b486f8ab96c01c02f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "af205d729450b663f48b11d839a1c8df") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "0d3f91798fac6ee279ec2485b25f1124") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4c3c7c067634daec9716a80ea886d123") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "d1e358e6e3b707282cdd06e919f7e08c") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "8c6ded4f0af86e0a7e301f8a716c4363") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "4c2d8bcb02d982d7cb77f649c0a2dea8") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "bdb662f765cd310f2a547cab1cfecef6") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "08ff5f7301d30200ab89169f6afdb7af") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "6eb6a030bcce166534b95bc2ab45d9cf") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "1bb77918e5695c944be02c16ae29b25e") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "b6fe77c19f0f0f4946c761d62585bfea") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "e9e7e260dce84ffa6e0e7eb5fd9d37fc") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "eced9e0b81ef2bba605cbc5e2e76a1d0") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "ef1772b6dff9a122358552954ad0df65") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "3b0c8ac703f828b04c6c197006d17218") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "652b906d60af96844ebd21b674f35e93") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "dc2f2f2462a0d72358b2f99389458606") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "762fc2665994b217c52c3c2eb7d9f406") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "cc7ed669cf88f201c3297c6a91e1d18d") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "cced11f7bbbffea2f718903216643648") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "24612f0ce2c9d2cf2b022ef1e027a54f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "b06521f39153d618550606be297466d5") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "014842d480b571495a4a0363793f7367") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "c743a45e0d2e6a95cb859adae0248435") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "def5d97e01e1219fb2fc8da6c4d6ba2f") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "92cb737f8687ccb93022fdb411a77cca") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "a0d1395c7fb36247bfe2d49376d9d133") + ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . + "ab75504250558b788f99d1ebd219abf2")) + "AList of test input strings and stringified message-digests +according to my additional test suite") + +#+md5-testing +(defun test-with-testsuite (testsuite) + (loop for count from 1 + for (source . md5-string) in testsuite + for md5-digest = (md5sum-sequence source) + for md5-result-string = (md5-string md5-digest) + do + (format + *trace-output* + "~2&Test-Case ~D:~% Input: ~S~% Required: ~A~% Returned: ~A~%" + count source md5-string md5-result-string) + when (string= md5-string md5-result-string) + do (format *trace-output* " OK~%") + else + count 1 into failed + and do (format *trace-output* " FAILED~%") + finally + (format *trace-output* + "~2&~[All ~D test cases succeeded~:;~:*~D of ~D test cases failed~].~%" + failed (1- count)) + (return (zerop failed)))) + +#+md5-testing +(defun test-rfc1321 () + (test-with-testsuite +rfc1321-testsuite+)) + +#+md5-testing +(defun test-other () + (test-with-testsuite +other-testsuite+)) + +#+cmu +(eval-when (:compile-toplevel :execute) + (setq *features* *old-features*)) + +#+cmu +(eval-when (:compile-toplevel) + (setq ext:*inline-expansion-limit* *old-expansion-limit*)) Added: clfswm/contrib/server/net.fas ============================================================================== --- (empty file) +++ clfswm/contrib/server/net.fas Thu Aug 12 17:30:52 2010 @@ -0,0 +1,1042 @@ +(|SYSTEM|::|VERSION| '(20080430.)) +#0Y_ #0Y |CHARSET|::|UTF-8| +#Y(#:|1 14 (IN-PACKAGE :CL-USER)-1| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("CL-USER" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|26 57 (DEFPACKAGE :PORT (:USE :COMMON-LISP) ...)-3-1| + #18Y(00 00 00 00 00 00 00 00 20 01 DA 01 04 31 F0 3E 19 01) ("PORT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|26 57 (DEFPACKAGE :PORT (:USE :COMMON-LISP) ...)-3-2| + #17Y(00 00 00 00 00 00 00 00 20 01 DA DB 31 EC 3E 19 01) + (("COMMON-LISP") "PORT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|26 57 (DEFPACKAGE :PORT (:USE :COMMON-LISP) ...)-3-3| + #19Y(00 00 00 00 00 00 00 00 20 01 DA DB 63 2D 03 02 3E 19 01) + (("RESOLVE-HOST-IPADDR" "IPADDR-TO-DOTTED" "DOTTED-TO-IPADDR" + "IPADDR-CLOSURE" "HOSTENT" "HOSTENT-NAME" "HOSTENT-ALIASES" + "HOSTENT-ADDR-LIST" "HOSTENT-ADDR-TYPE" "SOCKET" "OPEN-SOCKET" + "SOCKET-HOST/PORT" "SOCKET-STRING" "SOCKET-SERVER" + "SET-SOCKET-STREAM-FORMAT" "SOCKET-ACCEPT" "OPEN-SOCKET-SERVER" + "SOCKET-SERVER-CLOSE" "SOCKET-SERVER-HOST/PORT" "SOCKET-SERVICE-PORT" + "SERVENT-NAME" "SERVENT-ALIASES" "SERVENT-PORT" "SERVENT-PROTO" + "SERVENT-P" "SERVENT" "NETWORK" "TIMEOUT" "LOGIN" "NET-PATH") + "PORT" |SYSTEM|::|INTERN-EXPORT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|26 57 (DEFPACKAGE :PORT (:USE :COMMON-LISP) ...)-3-4| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 D9 19 01) ("PORT") + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) +#Y(#:|59 59 (IN-PACKAGE :PORT)-4| + #17Y(00 00 00 00 00 00 00 00 20 01 DA 31 F6 0F 01 19 01) + ("PORT" |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|62 71 (DEFINE-CONDITION CODE (ERROR) ...)-5-1| + #94Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF E0 E1 E2 E3 + E4 E5 E6 63 E7 63 6F 0E 7B 0A E0 E9 E2 EA E4 EB E6 63 E7 63 6F 0E EC ED + 7B 0C E0 EE E2 EF E4 F0 E6 63 E7 63 6F 0E EC F1 7B 0C 7B 03 F2 B3 F3 F4 + F5 F6 63 F7 64 7B 04 33 02 23 37 09 16 01 DC 38 02 32 3A 3E 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|CODE| + :|DIRECT-SUPERCLASSES| |COMMON-LISP|::|ERROR| :|DIRECT-SLOTS| :|NAME| + |PORT|::|PROC| :|READERS| (|PORT|::|CODE-PROC|) :|INITARGS| (:|PROC|) + :|INITFORM| :|INITFUNCTION| |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| + |PORT|::|MESG| (|PORT|::|CODE-MESG|) (:|MESG|) :|TYPE| + (|COMMON-LISP|::|OR| |COMMON-LISP|::|NULL| |COMMON-LISP|::|SIMPLE-STRING|) + |PORT|::|ARGS| (|PORT|::|CODE-ARGS|) (:|ARGS|) |COMMON-LISP|::|LIST| + :|METACLASS| :|DOCUMENTATION| "An error in the user code." + (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) :|DIRECT-DEFAULT-INITARGS| + :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|62 71 (DEFINE-CONDITION CODE (ERROR) ...)-5-2| + #49Y(00 00 00 00 00 00 00 00 20 01 DA DB 38 01 8F 9E 03 DA 2F 02 DA DD DE 63 + DF E0 E1 E2 E3 E4 38 02 72 3A 64 38 02 72 3A 7B 02 7B 08 2D 03 0B 3E 19 + 01) + (|CLOS|::|PRINT-OBJECT| |SYSTEM|::|TRACED-DEFINITION| |SYSTEM|::|UNTRACE1| + #Y(#:|62 71 (DEFINE-CONDITION CODE (ERROR) ...)-5-2-1| + #25Y(00 00 00 00 01 00 00 00 20 02 00 2B 01 7F 02 00 00 AC 6D 00 01 C6 + 5D 19 03) + (#Y(#:|62 71 (DEFINE-CONDITION CODE (ERROR) ...)-5-2-1-1| + #55Y(00 00 00 00 03 00 00 00 20 04 0E 01 1C 1C 0E 02 1C 18 AD DE B0 + 6F 05 B1 6F 06 B2 6F 07 2D 05 08 9F 19 04 14 AF AF 36 02 19 04 + 92 03 76 69 00 01 AF AF 2D 03 03 19 04) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|*PRINT-ESCAPE*| + |COMMON-LISP|::|*PRINT-READABLY*| |CLOS|::|%NO-NEXT-METHOD| + #Y(#:|62 71 (DEFINE-CONDITION CODE (ERROR) ...)-5-2-1-1-1| + #58Y(00 00 00 00 02 00 00 00 21 18 DA B0 31 94 AF 2F 01 10 02 B1 + B3 31 8D 11 AF 2F 03 DE B0 31 94 9E 5B 1C 05 83 01 9E 19 04 + DF B0 31 94 AF 94 02 83 03 94 03 83 04 2D 03 06 1B 6B) + (#\[ |SYSTEM|::|STREAM-START-S-EXPRESSION| + |COMMON-LISP|::|*PRINT-RIGHT-MARGIN*| + |SYSTEM|::|STREAM-END-S-EXPRESSION| #\] #\Space + |SYSTEM|::|DO-FORMAT-INDIRECTION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |PORT|::|CODE-PROC| |PORT|::|CODE-MESG| |PORT|::|CODE-ARGS| + |COMMON-LISP|::|FORMAT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + :|QUALIFIERS| :|LAMBDA-LIST| + (|COMMON-LISP|::|CONDITION| |COMMON-LISP|::|STREAM|) |CLOS|::|SIGNATURE| + #(2. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + :|SPECIALIZERS| |PORT|::|CODE| |CLOS|::|DO-DEFMETHOD|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|62 71 (DEFINE-CONDITION CODE (ERROR) ...)-5-3| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|CODE|) + |COMMON-LISP|::|NIL|) +#Y(#:|73 77 (DEFINE-CONDITION CASE-ERROR (CODE) ...)-6-1| + #62Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF E0 E1 E2 E3 + E4 E5 E6 E5 6F 0D E8 E9 7B 0A 7B 01 EA B3 EB EC ED EE 63 EF 64 7B 04 33 + 02 23 37 09 16 01 DC 38 02 32 3A 3E 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|CASE-ERROR| + :|DIRECT-SUPERCLASSES| |PORT|::|CODE| :|DIRECT-SLOTS| :|NAME| + |PORT|::|MESG| :|READERS| (|PORT|::|CODE-MESG|) :|INITFORM| + "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]" :|INITFUNCTION| + |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| :|TYPE| + |COMMON-LISP|::|SIMPLE-STRING| :|METACLASS| :|DOCUMENTATION| + "An error in a case statement.\n +This carries the function name which makes the error message more useful." + (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) :|DIRECT-DEFAULT-INITARGS| + :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|73 77 (DEFINE-CONDITION CASE-ERROR (CODE) ...)-6-2| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|CASE-ERROR|) + |COMMON-LISP|::|NIL|) +#Y(#:|80 85 (DEFINE-CONDITION NOT-IMPLEMENTED (CODE) ...)-7-1| + #74Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF E0 E1 E2 E3 + E4 E5 E6 E5 6F 0D E8 E9 7B 0A E0 EA E2 EB E4 EC E6 ED E8 EE 7B 0A 7B 02 + EF B3 F0 F1 F2 F3 63 F4 64 7B 04 33 02 23 37 09 16 01 DC 38 02 32 3A 3E + 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|NOT-IMPLEMENTED| + :|DIRECT-SUPERCLASSES| |PORT|::|CODE| :|DIRECT-SLOTS| :|NAME| + |PORT|::|MESG| :|READERS| (|PORT|::|CODE-MESG|) :|INITFORM| + "not implemented for ~a [~a]" :|INITFUNCTION| + |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| :|TYPE| + |COMMON-LISP|::|SIMPLE-STRING| |PORT|::|ARGS| (|PORT|::|CODE-ARGS|) + (|COMMON-LISP|::|LIST| (|COMMON-LISP|::|LISP-IMPLEMENTATION-TYPE|) + (|COMMON-LISP|::|LISP-IMPLEMENTATION-VERSION|)) + #Y(|PORT|::|DEFAULT-ARGS| + #18Y(00 00 00 00 00 00 00 00 26 01 71 CE 71 CF 61 02 19 01) () + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) () + |COMMON-LISP|::|NIL| 1) + |COMMON-LISP|::|LIST| :|METACLASS| :|DOCUMENTATION| + "Your implementation does not support this functionality." + (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) :|DIRECT-DEFAULT-INITARGS| + :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|80 85 (DEFINE-CONDITION NOT-IMPLEMENTED (CODE) ...)-7-2| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|NOT-IMPLEMENTED|) + |COMMON-LISP|::|NIL|) +#Y(#:|88 95 (DEFMACRO WITH-GENSYMS (# &BODY BODY) ...)-8| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|PORT|::|WITH-GENSYMS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|WITH-GENSYMS| + #101Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 64 2D 04 01 1D 19 9F 5C 78 + AC DD DD 64 2D 04 01 1D 12 AC 94 00 95 01 A3 5C 79 E5 63 AF 1B 2A + AE 2F 02 19 03 DE DF B1 E0 B0 E1 6F 08 E3 B3 E4 33 07 1F 94 00 AC + E6 E7 B5 B0 72 A6 E8 73 03 26 7B 02 7B 02 84 02 16 01 83 00 AC 8D + 9F 65 16 01 AC 80 B1 00 9F 5D 5D 19 08) + (2. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| 1. + |EXT|::|SOURCE-PROGRAM-ERROR| :|FORM| :|DETAIL| + "~S: ~S does not match lambda list element ~:S" |SYSTEM|::|TEXT| + |PORT|::|WITH-GENSYMS| + #1=(|PORT|::|TITLE| |COMMON-LISP|::|&REST| |PORT|::|NAMES|) + |COMMON-LISP|::|LET| |COMMON-LISP|::|GENSYM| |COMMON-LISP|::|STRING| + "-") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) + "Bind symbols in NAMES to gensyms. TITLE is a string - `gensym' prefix.\n +Inspired by Paul Graham, , p. 145." + 1) + (#1# |COMMON-LISP|::|&BODY| |PORT|::|BODY|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|97 104 (DEFMACRO DEFCONST (NAME TYPE INIT ...) ...)-9| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|PORT|::|DEFCONST| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|DEFCONST| + #71Y(00 00 00 00 02 00 00 00 26 03 AE DA DA 63 2D 04 01 1D 2C 9F 5C 78 + A0 5C 5C 78 A1 5C 5C 5C 78 B1 71 A2 DD DE DF B1 B3 7B 03 7B 02 B0 + E0 8A 07 14 CE 14 B2 E4 B3 B3 7B 03 B1 7B 04 61 03 19 07 AE 2F 02 + 19 03 CD 1B 6A) + (5. |SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|MACRO-CALL-ERROR| + |COMMON-LISP|::|PROGN| |COMMON-LISP|::|DECLAIM| |COMMON-LISP|::|TYPE| + (|COMMON-LISP|::|OR| |COMMON-LISP|::|SYMBOL| |COMMON-LISP|::|NUMBER| + |COMMON-LISP|::|CHARACTER|) + |COMMON-LISP|::|SUBTYPEP| |COMMON-LISP|::|DEFCONSTANT| + |COMMON-LISP|::|DEFVAR| |COMMON-LISP|::|THE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) + "Define a typed constant." 1) + (|PORT|::|NAME| |COMMON-LISP|::|TYPE| |PORT|::|INIT| |PORT|::|DOC|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|106 108 (DEFCONST +EOF+ CONS ...)-10-1| + #16Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 3E 19 01) + ((|COMMON-LISP|::|TYPE| |COMMON-LISP|::|CONS| |PORT|::|+EOF+|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|106 108 (DEFCONST +EOF+ CONS ...)-10-2| + #32Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 DB 8C 57 06 DB DB 7B 01 31 5A DB + DC DD 2D 03 04 C6 19 01) + ((|COMMON-LISP|::|SPECIAL| |PORT|::|+EOF+|) |PORT|::|+EOF+| + |COMMON-LISP|::|VARIABLE| + "*The end-of-file object.\n +To be passed as the third arg to `read' and checked against using `eq'." + |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|110 129 (DEFUN STRING-TOKENS (STRING &KEY # ...) ...)-11| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|STRING-TOKENS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|STRING-TOKENS| + #136Y(03 00 01 00 01 00 00 00 A6 1C 04 00 00 00 3B 04 02 C9 FC 3D 03 3D + 02 3B 01 03 DF 31 D9 10 06 92 05 0C B4 B4 B4 72 8D 53 80 52 01 02 + 1B 3C B3 01 02 DE 1B 05 AE 84 01 85 00 B5 AD 90 01 2F 1E 93 0A 06 + AF B7 90 01 34 15 B8 63 6B 07 38 01 B3 BB 31 89 42 02 6A 04 6A 02 + 14 0E 07 23 57 AD 72 64 B0 40 02 16 04 1B 1E AD 84 00 B0 63 B2 38 + 01 80 7F 01 14 A2 23 71 AC 31 B1 16 02 54 67 00 00 00 2F 08 55 16 + 01 11 19 06) + (:|START| :|END| :|MAX| :|PACKAGE| 0. :|KEYWORD| + |COMMON-LISP|::|*PACKAGE*| |PORT|::|+EOF+| |COMMON-LISP|::|CLOSE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|STRING| |COMMON-LISP|::|&KEY| (|PORT|::|START| 0.) + |PORT|::|END| |COMMON-LISP|::|MAX| + ((:|PACKAGE| |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|FIND-PACKAGE| :|KEYWORD|))) + "Read from STRING repeatedly, starting with START, up to MAX tokens.\n +Return the list of objects read and the final index in STRING.\n +Binds `*package*' to the KEYWORD package (or argument),\n +so that the bare symbols are read as keywords." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|133 144 (DEFMACRO COMPOSE (&REST FUNCTIONS) ...)-12| + #23Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC DD 72 4C 32 9C C5 19 01) + (|PORT|::|COMPOSE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|COMPOSE| + #27Y(00 00 00 00 02 00 00 00 26 03 95 02 DA 72 AA DB AD 7B 01 AF AF C7 + 74 61 03 19 05) + ("COMPOSE-ARG-" |COMMON-LISP|::|LAMBDA| + #Y(|PORT|::|COMPOSE-REC| + #54Y(00 00 00 00 02 00 00 00 26 03 94 02 A0 5C 1C 13 9F 14 7B 02 A0 + 5B 20 1B DA A1 5B 78 24 01 0B 9E 5D 19 04 95 03 AF 28 62 1B 67 + A1 5B 5C 78 9F 5C 5D 1B 6D 15 19 03) + (|COMMON-LISP|::|FUNCALL| |COMMON-LISP|::|QUOTE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|XX| |PORT|::|YY|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|SYSTEM|::|| |SYSTEM|::||) + "Macro: compose functions or macros of 1 argument into a lambda.\n +E.g., (compose abs (dl-val zz) 'key) ==>\n + (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))" + 1) + (|COMMON-LISP|::|&REST| |PORT|::|FUNCTIONS|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|149 154 (DECLAIM (FTYPE # IPADDR-TO-DOTTED))-13| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| ((|COMMON-LISP|::|UNSIGNED-BYTE| 32.)) + (|COMMON-LISP|::|VALUES| |COMMON-LISP|::|SIMPLE-STRING|)) + |PORT|::|IPADDR-TO-DOTTED|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|155 164 (DEFUN IPADDR-TO-DOTTED (IPADDR) ...)-14| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|IPADDR-TO-DOTTED| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|IPADDR-TO-DOTTED| + #90Y(00 00 00 00 01 00 00 00 26 02 38 02 72 8F DA AF DB 72 EC 73 02 40 + DA B0 DC 72 EC 73 02 40 DA B1 DD 72 EC 73 02 40 DA B2 73 02 40 B0 + 01 06 B6 2D 08 04 DF B1 31 94 B0 01 06 B5 2D 08 04 DF B1 31 94 B0 + 01 06 B4 2D 08 04 DF B1 31 94 B0 01 06 B3 2D 08 04 16 04 AC 32 90 + 19 03) + (255. -24. -16. -8. |SYSTEM|::|DO-FORMAT-DECIMAL| #\.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|IPADDR|) "Number --> string." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|166 167 (DECLAIM (FTYPE # DOTTED-TO-IPADDR))-15| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 31 62 19 01) + ((|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|STRING|) + (|COMMON-LISP|::|VALUES| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.))) + |PORT|::|DOTTED-TO-IPADDR|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|168 177 (DEFUN DOTTED-TO-IPADDR (DOTTED) ...)-16| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|DOTTED-TO-IPADDR| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|DOTTED-TO-IPADDR| + #47Y(00 00 00 00 01 00 00 00 26 02 DA DB AF 38 07 72 71 6F 02 94 00 DD + 72 EC 9E 5C 78 DE 72 EC 9F 5C 5C 78 DF 72 EC A0 5C 5C 5C 78 33 04 + 37 19 03) + (#\Space #\. |PORT|::|STRING-TOKENS| 24. 16. 8.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|DOTTED|) "String --> number." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|179 204 (DEFSTRUCT HOSTENT "see gethostbyname(3) for details" ...)-17| + #628Y(00 00 00 00 00 00 00 00 20 01 00 2B 01 DA DB DC 38 01 72 9E 2F 03 5D + 0B 00 00 DA 2F 04 DA DF 32 A3 DA 68 01 00 E0 63 E1 E2 6B 09 E4 E5 E6 + E7 E8 E9 EA EB EC ED ED 6F 14 70 15 F0 F1 F2 F3 F4 63 6E 11 1B 6B 09 + E4 F6 E6 F7 E8 65 1E EA EB EC 01 02 6F 14 70 15 F0 65 1F F2 65 20 F4 + 63 6E 11 1B 6B 09 E4 65 21 E6 65 22 E8 65 1E EA EB EC 01 02 6F 14 70 + 15 F0 65 23 F2 65 24 F4 63 6E 11 1B 6B 09 E4 65 25 E6 65 26 E8 65 27 + EA EB EC 65 20 65 20 6F 14 70 15 F0 65 28 F2 65 29 F4 63 6E 11 1B 7B + 04 6B 2A E4 E5 E6 E7 E8 E9 EA EB EC ED ED 6F 14 70 15 F0 65 2B 65 2C + 65 2D 65 2E 65 2F 6E 11 30 6B 2A E4 F6 E6 F7 E8 65 1E EA EB EC 01 02 + 6F 14 70 15 F0 65 31 65 2C 65 32 65 2E 65 33 6E 11 30 6B 2A E4 65 21 + E6 65 22 E8 65 1E EA EB EC 01 02 6F 14 70 15 F0 65 34 65 2C 65 35 65 + 2E 65 36 6E 11 30 6B 2A E4 65 25 E6 65 26 E8 65 27 EA EB EC 65 20 65 + 20 6F 14 70 15 F0 65 37 65 2C 65 38 65 2E 65 39 6E 11 30 7B 04 2D 08 + 3A E0 2F 3B E0 AD 6D 3C 01 32 9C 16 01 65 3D 31 62 E2 2F 3B E2 65 3E + 65 3F 32 A2 E2 65 40 32 9C 65 41 31 62 E1 2F 3B E1 65 3E 65 42 32 A2 + E1 65 43 32 9C 65 44 31 62 65 45 31 62 65 46 2F 3B 65 46 65 3E 65 47 + 32 A2 65 46 65 48 32 9C 65 46 65 49 DA 32 A2 65 4A 31 62 65 4B 31 62 + 65 4C 2F 3B 65 4C 65 3E 65 4D 32 A2 65 4C 65 4E 32 9C 65 4C 65 49 DA + 32 A2 65 4F 31 62 65 50 31 62 65 51 2F 3B 65 51 65 3E 65 52 32 A2 65 + 51 65 53 32 9C 65 51 65 49 DA 32 A2 65 54 31 62 65 55 31 62 65 56 2F + 3B 65 56 65 3E 65 57 32 A2 65 56 65 58 32 9C 65 56 65 49 DA 32 A2 65 + 59 31 62 65 5A 31 62 65 5B 2F 3B 65 5B 65 3E 65 5C 32 A2 65 5B 65 5D + 32 9C 65 46 65 5E DA 32 A2 65 5F 31 62 65 60 31 62 65 61 2F 3B 65 61 + 65 3E 65 62 32 A2 65 61 65 63 32 9C 65 4C 65 5E DA 32 A2 65 64 31 62 + 65 65 31 62 65 66 2F 3B 65 66 65 3E 65 67 32 A2 65 66 65 68 32 9C 65 + 51 65 5E DA 32 A2 65 69 31 62 65 6A 31 62 65 6B 2F 3B 65 6B 65 3E 65 + 6C 32 A2 65 6B 65 6D 32 9C 65 56 65 5E DA 32 A2 DA 65 6E 65 6F 2D 03 + 70 DA 2F 71 C5 19 01) + (|PORT|::|HOSTENT| |COMMON-LISP|::|STRUCTURE-OBJECT| |CLOS|::|CLOSCLASS| + |CLOS|::|CLASS-NAMES| |SYSTEM|::|STRUCTURE-UNDEFINE-ACCESSORIES| + |SYSTEM|::|DEFSTRUCT-DESCRIPTION| |PORT|::|MAKE-HOSTENT| + |PORT|::|COPY-HOSTENT| |PORT|::|HOSTENT-P| + |CLOS|::|| :|NAME| |PORT|::|NAME| + :|INITARGS| (:|NAME|) :|TYPE| |COMMON-LISP|::|SIMPLE-STRING| :|ALLOCATION| + :|INSTANCE| |CLOS|::|INHERITABLE-INITER| #1="" + |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| + |CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| |CLOS|::|INHERITABLE-DOC| + (|COMMON-LISP|::|NIL|) |CLOS|::|LOCATION| 1. |CLOS|::|READONLY| + |CLOS|::|MAKE-INSTANCE-| + |PORT|::|ALIASES| (:|ALIASES|) |COMMON-LISP|::|LIST| (|COMMON-LISP|::|NIL|) + 2. |PORT|::|ADDR-LIST| (:|ADDR-LIST|) (|COMMON-LISP|::|NIL|) 3. + |PORT|::|ADDR-TYPE| (:|ADDR-TYPE|) |COMMON-LISP|::|FIXNUM| + (|COMMON-LISP|::|NIL|) 4. |CLOS|::|| + (|COMMON-LISP|::|NIL|) :|READERS| (|PORT|::|HOSTENT-NAME|) :|WRITERS| + ((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|)) + |CLOS|::|MAKE-INSTANCE-| + (|COMMON-LISP|::|NIL|) (|PORT|::|HOSTENT-ALIASES|) + ((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|)) (|COMMON-LISP|::|NIL|) + (|PORT|::|HOSTENT-ADDR-LIST|) + ((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|)) + (|COMMON-LISP|::|NIL|) (|PORT|::|HOSTENT-ADDR-TYPE|) + ((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|)) + |CLOS|::|DEFINE-STRUCTURE-CLASS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|MAKE-HOSTENT| + #61Y(00 00 00 00 00 00 00 00 A6 1B 04 00 01 00 3B 04 02 CA FC 3D 03 3D + 02 3B 01 02 CB F9 69 00 01 E1 72 45 E2 AD E3 B4 32 44 E2 AD E0 B3 + 32 44 E2 AD E4 B2 32 44 E2 AD E5 B1 32 44 15 19 05) + (|COMMON-LISP|::|NIL| :|NAME| :|ALIASES| :|ADDR-LIST| :|ADDR-TYPE| #1# + 2. 5. |PORT|::|HOSTENT| 1. 3. 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&KEY| (#:|NAME| #1#) (#:|ALIASES| |COMMON-LISP|::|NIL|) + (#:|ADDR-LIST| |COMMON-LISP|::|NIL|) (#:|ADDR-TYPE| 2.)) + |COMMON-LISP|::|NIL| 1) + (|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-P|) |SYSTEM|::|INLINE-EXPANSION| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-P|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-P| + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT|))) + #Y(|PORT|::|HOSTENT-P| + #16Y(00 00 00 00 01 00 00 00 20 02 DA AE 32 47 19 02) + (|PORT|::|HOSTENT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|INLINE| |PORT|::|COPY-HOSTENT|) + ((|COMMON-LISP|::|STRUCTURE|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|COPY-HOSTENT|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|COPY-HOSTENT| + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|))) + #Y(|PORT|::|COPY-HOSTENT| + #15Y(00 00 00 00 01 00 00 00 26 02 AD 32 46 19 02) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|STRUCTURE|) |COMMON-LISP|::|NIL| 1) + (|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-NAME| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|SIMPLE-STRING|) + (|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-NAME|) |PORT|::|HOSTENT-NAME| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-NAME|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-NAME| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1.)))) + #Y(|PORT|::|HOSTENT-NAME| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|HOSTENT| 1.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + |SYSTEM|::|DEFSTRUCT-READER| + (|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ALIASES| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ALIASES|) + |PORT|::|HOSTENT-ALIASES| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-ALIASES|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ALIASES| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2.)))) + #Y(|PORT|::|HOSTENT-ALIASES| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|HOSTENT| 2.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ADDR-LIST| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ADDR-LIST|) + |PORT|::|HOSTENT-ADDR-LIST| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-ADDR-LIST|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-LIST| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3.)))) + #Y(|PORT|::|HOSTENT-ADDR-LIST| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|HOSTENT| 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ADDR-TYPE| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|FIXNUM|) + (|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ADDR-TYPE|) + |PORT|::|HOSTENT-ADDR-TYPE| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-ADDR-TYPE|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-TYPE| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4.)))) + #Y(|PORT|::|HOSTENT-ADDR-TYPE| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|HOSTENT| 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|) + (|COMMON-LISP|::|SIMPLE-STRING| |PORT|::|HOSTENT|) + |COMMON-LISP|::|SIMPLE-STRING|) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|HOSTENT-NAME|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| #2=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-NAME| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| . + #3=(|SYSTEM|::|VALUE|))))) + #Y(#2# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|HOSTENT| 1.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |SYSTEM|::|DEFSTRUCT-WRITER| + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|) + (|COMMON-LISP|::|LIST| |PORT|::|HOSTENT|) |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|HOSTENT-ALIASES|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #4=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ALIASES| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| . #3#)))) + #Y(#4# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|HOSTENT| 2.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|) + (|COMMON-LISP|::|LIST| |PORT|::|HOSTENT|) |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|HOSTENT-ADDR-LIST|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #5=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-LIST| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| . #3#)))) + #Y(#5# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|HOSTENT| 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|) + (|COMMON-LISP|::|FIXNUM| |PORT|::|HOSTENT|) |COMMON-LISP|::|FIXNUM|) + (|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|HOSTENT-ADDR-TYPE|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #6=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-TYPE| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| . #3#)))) + #Y(#6# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|HOSTENT| 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| "see gethostbyname(3) for details" + |SYSTEM|::|%SET-DOCUMENTATION| + |CLOS|::|DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|204 291 (DEFUN RESOLVE-HOST-IPADDR (HOST) ...)-18| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|RESOLVE-HOST-IPADDR| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|RESOLVE-HOST-IPADDR| + #42Y(00 00 00 00 01 00 00 00 26 02 AD 6F 00 DB DC AE DD 72 43 DE DC B0 + DF 72 43 E0 DC B2 E1 72 43 E2 DC B4 E3 72 43 2D 08 0A 19 03) + (|POSIX|::|RESOLVE-HOST-IPADDR| :|NAME| |POSIX|::|HOSTENT| 1. :|ALIASES| + 2. :|ADDR-LIST| 3. :|ADDR-TYPE| 4. |PORT|::|MAKE-HOSTENT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|HOST|) "Call gethostbyname(3) or gethostbyaddr(3)." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|293 306 (DEFUN IPADDR-CLOSURE (ADDRESS) ...)-19| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|IPADDR-CLOSURE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|IPADDR-CLOSURE| + #58Y(00 00 00 00 01 00 00 00 26 02 00 2B 02 38 09 C5 FB 31 6D 0B 00 00 + 38 09 C5 FB 31 6D 0B 00 01 9D 2B 01 AC 2C 01 01 0B 00 00 AF 06 01 + 00 34 16 01 68 00 01 68 01 00 40 02 19 03) + (|COMMON-LISP|::|EQUALP| + #Y(|PORT|::|IPADDR-CLOSURE-HANDLE| + #84Y(00 00 00 00 01 00 00 00 26 02 AD 69 01 01 38 01 8C 6E 3E AD 6F + 01 69 01 01 AF AD AF 31 6F 16 01 69 01 02 AD AD 38 01 71 6E AE + AE B2 A0 7A 31 6F 16 02 DC AD DD 72 43 28 51 69 00 01 DC AE DE + 72 43 33 00 18 69 00 01 DC AE DF 72 43 33 00 18 19 03 00 19 02) + (|COMMON-LISP|::|NIL| |PORT|::|RESOLVE-HOST-IPADDR| + |PORT|::|HOSTENT| 1. 2. 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|S|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|ADDRESS|) + "Resolve all addresses and names associated with the argument." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|308 323 (DEFTYPE SOCKET NIL ...)-20| + #24Y(00 00 00 00 00 00 00 00 20 01 DA DB DC 32 A2 DA DD 63 2D 03 04 C5 19 + 01) + (|PORT|::|SOCKET| |SYSTEM|::|DEFTYPE-EXPANDER| + #Y(#:|DEFTYPE-SOCKET| + #26Y(00 00 00 00 01 00 00 00 20 02 AD DA DA 2D 03 01 1D 03 C8 19 02 AD + 2F 02 19 02) + (1. |SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| + |SYSTEM|::|TYPE-CALL-ERROR| |COMMON-LISP|::|STREAM|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|325 376 (DEFUN OPEN-SOCKET (HOST PORT &OPTIONAL ...) ...)-21| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|OPEN-SOCKET| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|OPEN-SOCKET| + #61Y(00 00 00 00 02 00 01 00 26 09 3D 01 AF 8E 19 1B AF 8E 1E 1A AF DD + DE 70 05 E0 2D 03 07 14 AF AD E2 92 05 16 CF 14 2D 04 0B 19 05 A0 + 1B 6F AF 6F 00 DB AD DC 32 43 16 01 1B 63 CE 1B 68) + (|PORT|::|RESOLVE-HOST-IPADDR| |PORT|::|HOSTENT| 1. |PORT|::|HOST| + (|COMMON-LISP|::|STRING| |COMMON-LISP|::|INTEGER|) + |SYSTEM|::|TYPECASE-ERROR-STRING| + (|COMMON-LISP|::|OR| |COMMON-LISP|::|STRING| |COMMON-LISP|::|INTEGER|) + |SYSTEM|::|ETYPECASE-FAILED| :|ELEMENT-TYPE| + (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) |COMMON-LISP|::|CHARACTER| + |SOCKET|::|SOCKET-CONNECT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|HOST| |PORT|::|PORT| |COMMON-LISP|::|&OPTIONAL| |PORT|::|BIN|) + "Open a socket connection to HOST at PORT." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|378 384 (DEFUN SET-SOCKET-STREAM-FORMAT (SOCKET FORMAT) ...)-22| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SET-SOCKET-STREAM-FORMAT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SET-SOCKET-STREAM-FORMAT| + #16Y(00 00 00 00 02 00 00 00 26 03 AD AF 30 00 19 03) + (#.(|SYSTEM|::|GET-SETF-SYMBOL| '|COMMON-LISP|::|STREAM-ELEMENT-TYPE|)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|SOCKET| |COMMON-LISP|::|FORMAT|) + "switch between binary and text output" 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|386 456 (DEFUN SOCKET-HOST/PORT (SOCK) ...)-23| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SOCKET-HOST/PORT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SOCKET-HOST/PORT| + #32Y(00 00 00 00 01 00 00 00 26 02 AD 2F 00 42 02 AF 2F 01 42 02 AF C7 + 74 AF AF C7 74 AF 40 04 19 06) + (|SOCKET|::|SOCKET-STREAM-PEER| |SOCKET|::|SOCKET-STREAM-LOCAL| + #Y(|PORT|::|SOCKET-HOST/PORT-IP| + #24Y(00 00 00 00 01 00 00 00 26 02 AD DA DB B0 38 06 C7 F9 72 7A 32 + 60 19 02) + (0. #\Space #.#'|COMMON-LISP|::|CHAR=|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|HO|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|SOCK|) "Return the remote and local host&port, as 4 values." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|458 464 (DEFUN SOCKET-STRING (SOCK) ...)-24| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SOCKET-STRING| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SOCKET-STRING| + #66Y(03 00 01 00 01 00 00 00 26 02 00 2B 01 7F 02 00 00 9D 2B 01 DA 38 + 01 32 8F 0B 00 00 53 17 AE 6D 01 01 68 04 00 68 04 00 DC 64 DD 64 + 2D 07 04 68 02 00 32 90 54 08 00 00 00 00 14 38 01 32 97 55 19 04) + (|COMMON-LISP|::|CHARACTER| + #Y(|PORT|::|SOCKET-STRING-1| + #30Y(00 00 00 00 00 00 00 00 26 01 69 01 01 2F 01 42 04 69 00 01 DC + AF AF B3 B3 2D 06 03 19 05) + (|COMMON-LISP|::|NIL| |PORT|::|SOCKET-HOST/PORT| + #Y(|PORT|::|SOCKET-STRING-1-1| + #68Y(00 00 00 00 05 00 00 00 21 00 DA B3 38 02 31 95 B1 B3 31 90 + DB B3 31 94 B2 01 06 B7 2D 08 02 DD B3 38 02 31 95 B2 2F 04 + 10 05 B2 B6 31 8D 11 B2 2F 06 DB B3 31 94 B2 01 06 B5 2D 08 + 02 E1 B3 31 94 9E 19 07) + ("[local: " #\: |SYSTEM|::|DO-FORMAT-DECIMAL| "] [peer: " + |SYSTEM|::|STREAM-START-S-EXPRESSION| + |COMMON-LISP|::|*PRINT-RIGHT-MARGIN*| + |SYSTEM|::|STREAM-END-S-EXPRESSION| #\]) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|FORMAT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) () + |COMMON-LISP|::|NIL| 1) + :|TYPE| :|IDENTITY| |SYSTEM|::|WRITE-UNREADABLE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|SOCK|) "Print the socket local&peer host&port to a string." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|466 484 (DEFTYPE SOCKET-SERVER NIL ...)-25| + #24Y(00 00 00 00 00 00 00 00 20 01 DA DB DC 32 A2 DA DD 63 2D 03 04 C5 19 + 01) + (|PORT|::|SOCKET-SERVER| |SYSTEM|::|DEFTYPE-EXPANDER| + #Y(#:|DEFTYPE-SOCKET-SERVER| + #26Y(00 00 00 00 01 00 00 00 20 02 AD DA DA 2D 03 01 1D 03 C8 19 02 AD + 2F 02 19 02) + (1. |SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| + |SYSTEM|::|TYPE-CALL-ERROR| |SOCKET|::|SOCKET-SERVER|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| |SYSTEM|::|%SET-DOCUMENTATION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|486 522 (DEFUN OPEN-SOCKET-SERVER (&OPTIONAL PORT) ...)-26| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|OPEN-SOCKET-SERVER| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|OPEN-SOCKET-SERVER| + #17Y(00 00 00 00 00 00 01 00 26 07 3D 01 AD 2F 00 19 02) + (|SOCKET|::|SOCKET-SERVER|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&OPTIONAL| |PORT|::|PORT|) + "Open a `generic' socket server." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|524 601 (DEFUN SOCKET-ACCEPT (SERV &KEY BIN ...) ...)-27| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SOCKET-ACCEPT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SOCKET-ACCEPT| + #69Y(00 00 00 00 01 00 00 00 A6 1C 02 00 00 00 3D 02 3B 01 0A 7D 01 93 + 01 08 1B 07 CB 1B 20 92 01 01 C7 14 38 01 32 CE 42 02 B1 93 04 01 + 9F 14 AE DD 72 D1 2D 03 04 1F 0C B1 DF 92 06 5E CC 14 2D 03 08 19 + 06 19 06) + (:|BIN| :|WAIT| 0. 1.0d-6 |SOCKET|::|SOCKET-WAIT| :|ELEMENT-TYPE| + (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) |COMMON-LISP|::|CHARACTER| + |SOCKET|::|SOCKET-ACCEPT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|SERV| |COMMON-LISP|::|&KEY| |PORT|::|BIN| |PORT|::|WAIT|) + "Accept a connection on a socket server (passive socket).\n +Keyword arguments are:\n + BIN - create a binary stream;\n + WAIT - wait for the connection this many seconds\n + (the default is NIL - wait forever).\n +Returns a socket stream or NIL." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|603 619 (DEFUN SOCKET-SERVER-CLOSE (SERVER) ...)-28| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SOCKET-SERVER-CLOSE| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SOCKET-SERVER-CLOSE| + #15Y(00 00 00 00 01 00 00 00 26 02 AD 2F 00 19 02) + (|SOCKET|::|SOCKET-SERVER-CLOSE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|SERVER|) "Close the server." 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|621 652 (DEFUN SOCKET-SERVER-HOST/PORT (SERVER) ...)-29| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SOCKET-SERVER-HOST/PORT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SOCKET-SERVER-HOST/PORT| + #20Y(00 00 00 00 01 00 00 00 26 02 AD 6F 00 AE 6F 01 40 02 19 02) + (|SOCKET|::|SOCKET-SERVER-HOST| |SOCKET|::|SOCKET-SERVER-PORT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|SERVER|) + "Return the local host&port on which the server is running, as 2 values." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|654 678 (DEFUN WAIT-FOR-STREAM (STREAM &OPTIONAL TIMEOUT) ...)-30| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|WAIT-FOR-STREAM| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|WAIT-FOR-STREAM| + #46Y(00 00 00 00 01 00 01 00 26 08 3B 01 07 7D 01 93 01 05 1B 04 92 01 + 01 C5 14 38 01 32 CE 42 02 B0 93 04 01 9F 14 AE DB 72 D1 2D 03 02 + 19 05) + (0. 1.0d-6 |SOCKET|::|SOCKET-STATUS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|STREAM| |COMMON-LISP|::|&OPTIONAL| |PORT|::|TIMEOUT|) + "Sleep until there is input on the STREAM, or for TIMEOUT seconds,\n +whichever comes first. If there was a timeout, return NIL." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|680 702 (DEFUN OPEN-UNIX-SOCKET (PATH &KEY # ...) ...)-31| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|OPEN-UNIX-SOCKET| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|OPEN-UNIX-SOCKET| + #32Y(00 00 00 00 01 00 00 00 A6 1C 02 00 00 00 3D 01 AF DC 38 05 92 08 + 06 C9 FC 32 0B 19 04 C8 1B 78) + (:|KIND| :|BIN| :|IO| (|COMMON-LISP|::|UNSIGNED-BYTE| 8.) + |COMMON-LISP|::|CHARACTER|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|PATH| |COMMON-LISP|::|&KEY| (|PORT|::|KIND| :|STREAM|) + |PORT|::|BIN|) + "Opens a unix socket. Path is the location.\n +Kind can be :stream or :datagram." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|704 711 (DEFUN REPORT-NETWORK-CONDITION (CC OUT) ...)-32| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|REPORT-NETWORK-CONDITION| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|REPORT-NETWORK-CONDITION| + #32Y(00 00 00 00 02 00 00 00 26 03 AD DA B0 6F 01 B1 6F 02 B2 6F 03 B3 + 6F 04 B4 6F 05 2D 07 06 19 03) + (#Y(|PORT|::|REPORT-NETWORK-CONDITION-1| + #84Y(00 00 00 00 04 00 00 00 21 1A DA B2 31 94 B1 2F 01 10 02 B3 B5 + 31 8D 11 B1 2F 03 DE B2 38 02 31 95 B1 2F 01 10 02 B2 B5 31 8D + 11 B1 2F 03 DF B2 31 94 B1 01 06 B5 2D 08 06 9E 5B 1C 05 83 01 + 9E 19 06 E1 B2 31 94 B1 94 02 83 03 94 03 83 04 2D 03 08 1B 6B) + (#\[ |SYSTEM|::|STREAM-START-S-EXPRESSION| + |COMMON-LISP|::|*PRINT-RIGHT-MARGIN*| + |SYSTEM|::|STREAM-END-S-EXPRESSION| "] " #\: + |SYSTEM|::|DO-FORMAT-DECIMAL| #\Space + |SYSTEM|::|DO-FORMAT-INDIRECTION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |PORT|::|NET-PROC| |PORT|::|NET-HOST| |PORT|::|NET-PORT| + |PORT|::|NET-MESG| |PORT|::|NET-ARGS| |COMMON-LISP|::|FORMAT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|PORT|::|CC| |PORT|::|OUT|) |COMMON-LISP|::|NIL| 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|713 720 (DEFINE-CONDITION NETWORK (ERROR) ...)-33-1| + #138Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF E0 E1 E2 + E3 E4 E5 E6 63 E7 63 6F 0E E9 EA 7B 0C E0 EB E2 EC E4 ED E6 EE E7 EE + 6F 0E E9 EF 7B 0C E0 F0 E2 F1 E4 F2 E6 F3 E7 F3 6F 0E E9 F4 7B 0C E0 + F5 E2 F6 E4 F7 E6 63 E7 63 6F 0E E9 65 1E 7B 0C E0 65 1F E2 65 20 E4 + 65 21 E6 63 E7 63 6F 0E E9 65 22 7B 0C 7B 05 65 23 B3 65 24 65 25 63 + 65 26 63 65 27 64 7B 06 33 02 23 37 07 16 01 DC 38 02 32 3A 3E 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|NETWORK| + :|DIRECT-SUPERCLASSES| |COMMON-LISP|::|ERROR| :|DIRECT-SLOTS| :|NAME| + |PORT|::|PROC| :|READERS| (|PORT|::|NET-PROC|) :|INITARGS| (:|PROC|) + :|INITFORM| :|INITFUNCTION| |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| :|TYPE| + |COMMON-LISP|::|SYMBOL| |PORT|::|HOST| (|PORT|::|NET-HOST|) (:|HOST|) "" + |COMMON-LISP|::|SIMPLE-STRING| |PORT|::|PORT| (|PORT|::|NET-PORT|) + (:|PORT|) 0. (|COMMON-LISP|::|UNSIGNED-BYTE| 16.) |PORT|::|MESG| + (|PORT|::|NET-MESG|) (:|MESG|) + (|COMMON-LISP|::|OR| |COMMON-LISP|::|NULL| |COMMON-LISP|::|SIMPLE-STRING|) + |PORT|::|ARGS| (|PORT|::|NET-ARGS|) (:|ARGS|) |COMMON-LISP|::|LIST| + :|METACLASS| (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + :|DIRECT-DEFAULT-INITARGS| :|DOCUMENTATION| :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|713 720 (DEFINE-CONDITION NETWORK (ERROR) ...)-33-2| + #49Y(00 00 00 00 00 00 00 00 20 01 DA DB 38 01 8F 9E 03 DA 2F 02 DA DD DE 63 + DF E0 E1 E2 E3 E4 38 02 72 3A 64 38 02 72 3A 7B 02 7B 08 2D 03 0B 3E 19 + 01) + (|CLOS|::|PRINT-OBJECT| |SYSTEM|::|TRACED-DEFINITION| |SYSTEM|::|UNTRACE1| + #Y(#:|713 720 (DEFINE-CONDITION NETWORK (ERROR) ...)-33-2-1| + #25Y(00 00 00 00 01 00 00 00 20 02 00 2B 01 7F 02 00 00 AC 6D 00 01 C6 + 5D 19 03) + (#Y(#:|713 720 (DEFINE-CONDITION NETWORK (ERROR) ...)-33-2-1-1| + #45Y(00 00 00 00 03 00 00 00 20 04 0E 01 1C 12 0E 02 1C 0E AE AE 30 + 04 9F 19 04 14 AF AF 36 02 19 04 92 03 76 69 00 01 AF AF 2D 03 + 03 19 04) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|*PRINT-ESCAPE*| + |COMMON-LISP|::|*PRINT-READABLY*| |CLOS|::|%NO-NEXT-METHOD| + |PORT|::|REPORT-NETWORK-CONDITION|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + :|QUALIFIERS| :|LAMBDA-LIST| + (|COMMON-LISP|::|CONDITION| |COMMON-LISP|::|STREAM|) |CLOS|::|SIGNATURE| + #(2. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + :|SPECIALIZERS| |PORT|::|NETWORK| |CLOS|::|DO-DEFMETHOD|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|713 720 (DEFINE-CONDITION NETWORK (ERROR) ...)-33-3| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|NETWORK|) + |COMMON-LISP|::|NIL|) +#Y(#:|722 728 (DEFINE-CONDITION TIMEOUT (NETWORK) ...)-34-1| + #64Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF E0 E1 E2 E3 + E4 E5 E6 E7 E8 E7 6F 0F EA EB 7B 0C 7B 01 EC B3 ED EE 63 EF 63 F0 64 7B + 06 33 02 23 37 07 16 01 DC 38 02 32 3A 3E 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|TIMEOUT| + :|DIRECT-SUPERCLASSES| |PORT|::|NETWORK| :|DIRECT-SLOTS| :|NAME| + |COMMON-LISP|::|TIME| :|READERS| (|PORT|::|TIMEOUT-TIME|) :|INITARGS| + (:|TIME|) :|INITFORM| 0. :|INITFUNCTION| + |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| :|TYPE| (|COMMON-LISP|::|REAL| 0.) + :|METACLASS| (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + :|DIRECT-DEFAULT-INITARGS| :|DOCUMENTATION| :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|722 728 (DEFINE-CONDITION TIMEOUT (NETWORK) ...)-34-2| + #49Y(00 00 00 00 00 00 00 00 20 01 DA DB 38 01 8F 9E 03 DA 2F 02 DA DD DE 63 + DF E0 E1 E2 E3 E4 38 02 72 3A 64 38 02 72 3A 7B 02 7B 08 2D 03 0B 3E 19 + 01) + (|CLOS|::|PRINT-OBJECT| |SYSTEM|::|TRACED-DEFINITION| |SYSTEM|::|UNTRACE1| + #Y(#:|722 728 (DEFINE-CONDITION TIMEOUT (NETWORK) ...)-34-2-1| + #25Y(00 00 00 00 01 00 00 00 20 02 00 2B 01 7F 02 00 00 AC 6D 00 01 C6 + 5D 19 03) + (#Y(#:|722 728 (DEFINE-CONDITION TIMEOUT (NETWORK) ...)-34-2-1-1| + #59Y(00 00 00 00 03 00 00 00 20 04 0E 01 1C 20 0E 02 1C 1C AE AE 30 + 04 AE 6F 05 8F AD 08 AD E0 B0 6F 05 2D 03 07 9F 19 04 14 AF AF + 36 02 19 04 92 03 76 69 00 01 AF AF 2D 03 03 19 04) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|*PRINT-ESCAPE*| + |COMMON-LISP|::|*PRINT-READABLY*| |CLOS|::|%NO-NEXT-METHOD| + |PORT|::|REPORT-NETWORK-CONDITION| |PORT|::|TIMEOUT-TIME| + #Y(#:|722 728 (DEFINE-CONDITION TIMEOUT (NETWORK) ...)-34-2-1-1-1| + #29Y(00 00 00 00 02 00 00 00 21 18 DA B0 38 02 31 95 AE B0 31 90 + DB B0 38 02 31 95 9E 19 04) + (" [timeout " " sec]") + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|FORMAT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + :|QUALIFIERS| :|LAMBDA-LIST| + (|COMMON-LISP|::|CONDITION| |COMMON-LISP|::|STREAM|) |CLOS|::|SIGNATURE| + #(2. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + :|SPECIALIZERS| |PORT|::|TIMEOUT| |CLOS|::|DO-DEFMETHOD|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|722 728 (DEFINE-CONDITION TIMEOUT (NETWORK) ...)-34-3| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|TIMEOUT|) + |COMMON-LISP|::|NIL|) +#Y(#:|730 730 (DEFINE-CONDITION LOGIN (NETWORK) ...)-35-1| + #47Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF 63 E0 B3 E1 + E2 63 E3 63 E4 64 7B 06 33 02 23 37 07 16 01 DC 38 02 32 3A 3E 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|LOGIN| + :|DIRECT-SUPERCLASSES| |PORT|::|NETWORK| :|DIRECT-SLOTS| :|METACLASS| + (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) :|DIRECT-DEFAULT-INITARGS| + :|DOCUMENTATION| :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|730 730 (DEFINE-CONDITION LOGIN (NETWORK) ...)-35-2| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|LOGIN|) + |COMMON-LISP|::|NIL|) +#Y(#:|731 731 (DEFINE-CONDITION NET-PATH (NETWORK) ...)-36-1| + #47Y(00 00 00 00 00 00 00 00 20 01 6B 00 99 01 DC DD DE 7B 01 DF 63 E0 B3 E1 + E2 63 E3 63 E4 64 7B 06 33 02 23 37 07 16 01 DC 38 02 32 3A 3E 19 01) + (|CLOS|::|| |CLOS|::|ENSURE-CLASS| |PORT|::|NET-PATH| + :|DIRECT-SUPERCLASSES| |PORT|::|NETWORK| :|DIRECT-SLOTS| :|METACLASS| + (:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) :|DIRECT-DEFAULT-INITARGS| + :|DOCUMENTATION| :|GENERIC-ACCESSORS|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|731 731 (DEFINE-CONDITION NET-PATH (NETWORK) ...)-36-2| + #13Y(00 00 00 00 00 00 00 00 20 01 C5 19 01) (|PORT|::|NET-PATH|) + |COMMON-LISP|::|NIL|) +#Y(#:|733 742 (DEFSTRUCT SERVENT "see getservbyname(3) for details" ...)-37| + #632Y(00 00 00 00 00 00 00 00 20 01 00 2B 01 DA DB DC 38 01 72 9E 2F 03 5D + 0B 00 00 DA 2F 04 DA DF 32 A3 DA 68 01 00 E0 63 E1 E2 6B 09 E4 E5 E6 + E7 E8 E9 EA EB EC ED ED 6F 14 70 15 F0 F1 F2 F3 F4 63 6E 11 1B 6B 09 + E4 F6 E6 F7 E8 65 1E EA EB EC 01 02 6F 14 70 15 F0 65 1F F2 65 20 F4 + 63 6E 11 1B 6B 09 E4 65 21 E6 65 22 E8 65 23 EA EB EC 65 24 65 24 6F + 14 70 15 F0 65 25 F2 65 26 F4 63 6E 11 1B 6B 09 E4 65 27 E6 65 28 E8 + 65 29 EA EB EC 65 2A 65 2A 6F 14 70 15 F0 65 2B F2 65 2C F4 63 6E 11 + 1B 7B 04 6B 2D E4 E5 E6 E7 E8 E9 EA EB EC ED ED 6F 14 70 15 F0 65 2E + 65 2F 65 30 65 31 65 32 6E 11 33 6B 2D E4 F6 E6 F7 E8 65 1E EA EB EC + 01 02 6F 14 70 15 F0 65 34 65 2F 65 35 65 31 65 36 6E 11 33 6B 2D E4 + 65 21 E6 65 22 E8 65 23 EA EB EC 65 24 65 24 6F 14 70 15 F0 65 37 65 + 2F 65 38 65 31 65 39 6E 11 33 6B 2D E4 65 27 E6 65 28 E8 65 29 EA EB + EC 65 2A 65 2A 6F 14 70 15 F0 65 3A 65 2F 65 3B 65 31 65 3C 6E 11 33 + 7B 04 2D 08 3D E0 2F 3E E0 AD 6D 3F 01 32 9C 16 01 65 40 31 62 E2 2F + 3E E2 65 41 65 42 32 A2 E2 65 43 32 9C 65 44 31 62 E1 2F 3E E1 65 41 + 65 45 32 A2 E1 65 46 32 9C 65 47 31 62 65 48 31 62 65 49 2F 3E 65 49 + 65 41 65 4A 32 A2 65 49 65 4B 32 9C 65 49 65 4C DA 32 A2 65 4D 31 62 + 65 4E 31 62 65 4F 2F 3E 65 4F 65 41 65 50 32 A2 65 4F 65 51 32 9C 65 + 4F 65 4C DA 32 A2 65 52 31 62 65 53 31 62 65 54 2F 3E 65 54 65 41 65 + 55 32 A2 65 54 65 56 32 9C 65 54 65 4C DA 32 A2 65 57 31 62 65 58 31 + 62 65 59 2F 3E 65 59 65 41 65 5A 32 A2 65 59 65 5B 32 9C 65 59 65 4C + DA 32 A2 65 5C 31 62 65 5D 31 62 65 5E 2F 3E 65 5E 65 41 65 5F 32 A2 + 65 5E 65 60 32 9C 65 49 65 61 DA 32 A2 65 62 31 62 65 63 31 62 65 64 + 2F 3E 65 64 65 41 65 65 32 A2 65 64 65 66 32 9C 65 4F 65 61 DA 32 A2 + 65 67 31 62 65 68 31 62 65 69 2F 3E 65 69 65 41 65 6A 32 A2 65 69 65 + 6B 32 9C 65 54 65 61 DA 32 A2 65 6C 31 62 65 6D 31 62 65 6E 2F 3E 65 + 6E 65 41 65 6F 32 A2 65 6E 65 70 32 9C 65 59 65 61 DA 32 A2 DA 65 71 + 65 72 2D 03 73 DA 2F 74 C5 19 01) + (|PORT|::|SERVENT| |COMMON-LISP|::|STRUCTURE-OBJECT| |CLOS|::|CLOSCLASS| + |CLOS|::|CLASS-NAMES| |SYSTEM|::|STRUCTURE-UNDEFINE-ACCESSORIES| + |SYSTEM|::|DEFSTRUCT-DESCRIPTION| |PORT|::|MAKE-SERVENT| + |PORT|::|COPY-SERVENT| |PORT|::|SERVENT-P| + |CLOS|::|| :|NAME| |PORT|::|NAME| + :|INITARGS| (:|NAME|) :|TYPE| |COMMON-LISP|::|SIMPLE-STRING| :|ALLOCATION| + :|INSTANCE| |CLOS|::|INHERITABLE-INITER| #1="" + |SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| + |CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| |CLOS|::|INHERITABLE-DOC| + (|COMMON-LISP|::|NIL|) |CLOS|::|LOCATION| 1. |CLOS|::|READONLY| + |CLOS|::|MAKE-INSTANCE-| + |PORT|::|ALIASES| (:|ALIASES|) |COMMON-LISP|::|LIST| (|COMMON-LISP|::|NIL|) + 2. |PORT|::|PORT| (:|PORT|) |COMMON-LISP|::|FIXNUM| -1. + (|COMMON-LISP|::|NIL|) 3. |PORT|::|PROTO| (:|PROTO|) + |COMMON-LISP|::|SYMBOL| :|TCP| (|COMMON-LISP|::|NIL|) 4. + |CLOS|::|| (|COMMON-LISP|::|NIL|) + :|READERS| (|PORT|::|SERVENT-NAME|) :|WRITERS| + ((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|)) + |CLOS|::|MAKE-INSTANCE-| + (|COMMON-LISP|::|NIL|) (|PORT|::|SERVENT-ALIASES|) + ((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|)) (|COMMON-LISP|::|NIL|) + (|PORT|::|SERVENT-PORT|) ((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|)) + (|COMMON-LISP|::|NIL|) (|PORT|::|SERVENT-PROTO|) + ((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|)) + |CLOS|::|DEFINE-STRUCTURE-CLASS| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|MAKE-SERVENT| + #64Y(00 00 00 00 00 00 00 00 A6 1B 04 00 01 00 3B 04 02 CA FC 3D 03 3B + 02 02 CB FA 3B 01 02 CC F9 69 00 01 E2 72 45 E3 AD E4 B4 32 44 E3 + AD E5 B3 32 44 E3 AD E6 B2 32 44 E3 AD E7 B1 32 44 15 19 05) + (|COMMON-LISP|::|NIL| :|NAME| :|ALIASES| :|PORT| :|PROTO| #1# -1. :|TCP| + 5. |PORT|::|SERVENT| 1. 2. 3. 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&KEY| (#:|NAME| #1#) (#:|ALIASES| |COMMON-LISP|::|NIL|) + (#:|PORT| -1.) (#:|PROTO| :|TCP|)) + |COMMON-LISP|::|NIL| 1) + (|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-P|) |SYSTEM|::|INLINE-EXPANSION| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-P|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-P| + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT|))) + #Y(|PORT|::|SERVENT-P| + #16Y(00 00 00 00 01 00 00 00 20 02 DA AE 32 47 19 02) + (|PORT|::|SERVENT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|INLINE| |PORT|::|COPY-SERVENT|) + ((|COMMON-LISP|::|STRUCTURE|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|COPY-SERVENT|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|COPY-SERVENT| + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|))) + #Y(|PORT|::|COPY-SERVENT| + #15Y(00 00 00 00 01 00 00 00 26 02 AD 32 46 19 02) () + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|STRUCTURE|) |COMMON-LISP|::|NIL| 1) + (|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-NAME| (|PORT|::|SERVENT|) + |COMMON-LISP|::|SIMPLE-STRING|) + (|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-NAME|) |PORT|::|SERVENT-NAME| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-NAME|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-NAME| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1.)))) + #Y(|PORT|::|SERVENT-NAME| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|SERVENT| 1.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + |SYSTEM|::|DEFSTRUCT-READER| + (|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-ALIASES| (|PORT|::|SERVENT|) + |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-ALIASES|) + |PORT|::|SERVENT-ALIASES| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-ALIASES|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-ALIASES| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2.)))) + #Y(|PORT|::|SERVENT-ALIASES| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|SERVENT| 2.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-PORT| (|PORT|::|SERVENT|) + |COMMON-LISP|::|FIXNUM|) + (|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-PORT|) |PORT|::|SERVENT-PORT| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-PORT|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PORT| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3.)))) + #Y(|PORT|::|SERVENT-PORT| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|SERVENT| 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-PROTO| (|PORT|::|SERVENT|) + |COMMON-LISP|::|SYMBOL|) + (|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-PROTO|) |PORT|::|SERVENT-PROTO| + ((|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-PROTO|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PROTO| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4.)))) + #Y(|PORT|::|SERVENT-PROTO| + #17Y(00 00 00 00 01 00 00 00 20 02 DA AE DB 32 43 19 02) + (|PORT|::|SERVENT| 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|) + (|COMMON-LISP|::|SIMPLE-STRING| |PORT|::|SERVENT|) + |COMMON-LISP|::|SIMPLE-STRING|) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|SERVENT-NAME|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| #2=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-NAME| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| . + #3=(|SYSTEM|::|VALUE|))))) + #Y(#2# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|SERVENT| 1.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |SYSTEM|::|DEFSTRUCT-WRITER| + (|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|) + (|COMMON-LISP|::|LIST| |PORT|::|SERVENT|) |COMMON-LISP|::|LIST|) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|SERVENT-ALIASES|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #4=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-ALIASES| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| . #3#)))) + #Y(#4# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|SERVENT| 2.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|) + (|COMMON-LISP|::|FIXNUM| |PORT|::|SERVENT|) |COMMON-LISP|::|FIXNUM|) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|SERVENT-PORT|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| #5=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PORT| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| . #3#)))) + #Y(#5# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|SERVENT| 3.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + (|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|) + (|COMMON-LISP|::|SYMBOL| |PORT|::|SERVENT|) |COMMON-LISP|::|SYMBOL|) + (|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|)) + #.(|SYSTEM|::|GET-SETF-SYMBOL| '|PORT|::|SERVENT-PROTO|) + ((|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| + #6=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|))) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PROTO| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| . #3#)))) + #Y(#6# #18Y(00 00 00 00 02 00 00 00 20 03 DA AE DB B1 32 44 19 03) + (|PORT|::|SERVENT| 4.) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) + |COMMON-LISP|::|TYPE| "see getservbyname(3) for details" + |SYSTEM|::|%SET-DOCUMENTATION| + |CLOS|::|DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|742 776 (DEFUN SOCKET-SERVICE-PORT (&OPTIONAL SERVICE #) ...)-38| + #20Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 DA DC 32 9C C5 19 01) + (|PORT|::|SOCKET-SERVICE-PORT| |SYSTEM|::|REMOVE-OLD-DEFINITIONS| + #Y(|PORT|::|SOCKET-SERVICE-PORT| + #239Y(03 00 01 00 00 00 02 00 26 0C 3D 02 3B 01 02 C5 F9 DB DC 38 05 72 + 0B 53 80 C6 C8 45 01 07 1B 80 97 AD 72 62 8E AC 80 90 DE AE DF 71 + 32 90 01 07 80 86 E0 E1 AF DF DE B2 38 06 72 7A 72 60 38 07 72 74 + 2F 08 FA 78 71 51 38 02 80 4E 06 63 A0 5C 5C 79 1B 3E B8 B0 38 04 + 8D 41 80 5C B9 B3 38 04 8C 41 09 B9 B2 E3 38 02 8D C1 80 4C E4 B3 + E5 B4 E6 B5 E7 B6 2D 08 0E 16 07 1B 80 50 E9 EA BB BB 33 03 1E 94 + 00 AC 71 51 38 02 71 4E 84 02 16 01 83 00 AC 8D 9F 6D 16 01 AC 31 + B1 16 01 FD 9F 5C 5B FC 9F 5C 5C 5B FB 92 0D FF A9 E4 B3 E5 B4 E6 + B5 E7 B6 6E 08 0E 84 00 B6 01 02 38 01 80 82 01 1C FF 5E 92 0D FF + B5 AC 31 B1 16 07 41 05 00 00 02 1D 03 14 2F 11 46 54 05 00 00 00 + 1D 0E 1B 06 05 00 00 00 1D 06 14 EC 64 2D 03 11 55 19 04) + (#1="tcp" "/etc/services" :|INPUT| #.#'|COMMON-LISP|::|VALUES| #\# 0. + #\Space #\/ |PORT|::|STRING-TOKENS| #.#'|COMMON-LISP|::|STRING-EQUAL| + :|NAME| :|ALIASES| :|PORT| :|PROTO| |PORT|::|MAKE-SERVENT| + "~s: service ~s is not found for protocol ~s" + |PORT|::|SOCKET-SERVICE-PORT| |COMMON-LISP|::|CLOSE| :|ABORT|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|) + (|COMMON-LISP|::|&OPTIONAL| |PORT|::|SERVICE| (|PORT|::|PROTOCOL| #1#)) + "Return the SERVENT structure corresponding to the SERVICE.\n +When SERVICE is NIL, return the list of all services." + 1)) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) +#Y(#:|778 780 (PROVIDE :PORT-NET)-39| + #15Y(00 00 00 00 00 00 00 00 20 01 DA 2F 01 19 01) + (:|PORT-NET| |COMMON-LISP|::|PROVIDE|) + (|COMMON-LISP|::|T| |COMMON-LISP|::|T| |COMMON-LISP|::|T|)) Added: clfswm/contrib/server/net.lib ============================================================================== --- (empty file) +++ clfswm/contrib/server/net.lib Thu Aug 12 17:30:52 2010 @@ -0,0 +1,988 @@ +#0Y_ #0Y |CHARSET|::|UTF-8| +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "CL-USER")) +(|SYSTEM|::|%IN-PACKAGE| "PORT" :|NICKNAMES| '|COMMON-LISP|::|NIL| :|USE| + '|COMMON-LISP|::|NIL| :|CASE-SENSITIVE| |COMMON-LISP|::|NIL| :|CASE-INVERTED| + |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|USE-PACKAGE| '("COMMON-LISP") "PORT") +(|SYSTEM|::|INTERN-EXPORT| + '("RESOLVE-HOST-IPADDR" "IPADDR-TO-DOTTED" "DOTTED-TO-IPADDR" "IPADDR-CLOSURE" + "HOSTENT" "HOSTENT-NAME" "HOSTENT-ALIASES" "HOSTENT-ADDR-LIST" + "HOSTENT-ADDR-TYPE" "SOCKET" "OPEN-SOCKET" "SOCKET-HOST/PORT" + "SOCKET-STRING" "SOCKET-SERVER" "SET-SOCKET-STREAM-FORMAT" "SOCKET-ACCEPT" + "OPEN-SOCKET-SERVER" "SOCKET-SERVER-CLOSE" "SOCKET-SERVER-HOST/PORT" + "SOCKET-SERVICE-PORT" "SERVENT-NAME" "SERVENT-ALIASES" "SERVENT-PORT" + "SERVENT-PROTO" "SERVENT-P" "SERVENT" "NETWORK" "TIMEOUT" "LOGIN" + "NET-PATH") + "PORT" |COMMON-LISP|::|NIL|) +(|COMMON-LISP|::|FIND-PACKAGE| "PORT") +(|COMMON-LISP|::|SETQ| |COMMON-LISP|::|*PACKAGE*| + (|SYSTEM|::|%FIND-PACKAGE| "PORT")) +(|COMMON-LISP|::|LET*| ((#1=#:|G46976| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|CODE| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|COMMON-LISP|::|ERROR|) + :|DIRECT-SLOTS| + (|COMMON-LISP|::|LIST| + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|PROC| :|READERS| + '(|PORT|::|CODE-PROC|) :|INITARGS| '(:|PROC|) :|INITFORM| + '|COMMON-LISP|::|NIL| :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|MESG| :|READERS| + '(|PORT|::|CODE-MESG|) :|INITARGS| '(:|MESG|) :|INITFORM| + '|COMMON-LISP|::|NIL| :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|) :|TYPE| + '(|COMMON-LISP|::|OR| |COMMON-LISP|::|NULL| + |COMMON-LISP|::|SIMPLE-STRING|)) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|ARGS| :|READERS| + '(|PORT|::|CODE-ARGS|) :|INITARGS| '(:|ARGS|) :|INITFORM| + '|COMMON-LISP|::|NIL| :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|) :|TYPE| + '|COMMON-LISP|::|LIST|)) + :|METACLASS| #1# :|DOCUMENTATION| '"An error in the user code." + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|GENERIC-ACCESSORS| '|COMMON-LISP|::|T|)))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|CODE-PROC| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|CODE-MESG| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|CODE-ARGS| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|CLOS|::|PRINT-OBJECT| + #(2. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|COMMON-LISP|::|LET*| ((#1=#:|G47050| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|CASE-ERROR| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|PORT|::|CODE|) + :|DIRECT-SLOTS| + (|COMMON-LISP|::|LIST| + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|MESG| :|READERS| + '(|PORT|::|CODE-MESG|) :|INITFORM| + '#2="`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]" :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| #2#) :|TYPE| + '|COMMON-LISP|::|SIMPLE-STRING|)) + :|METACLASS| #1# :|DOCUMENTATION| + '"An error in a case statement.\n +This carries the function name which makes the error message more useful." + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|GENERIC-ACCESSORS| '|COMMON-LISP|::|T|)))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|CODE-MESG| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|COMMON-LISP|::|LET*| ((#1=#:|G47061| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|NOT-IMPLEMENTED| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|PORT|::|CODE|) + :|DIRECT-SLOTS| + (|COMMON-LISP|::|LIST| + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|MESG| :|READERS| + '(|PORT|::|CODE-MESG|) :|INITFORM| '#2="not implemented for ~a [~a]" + :|INITFUNCTION| (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| #2#) :|TYPE| + '|COMMON-LISP|::|SIMPLE-STRING|) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|ARGS| :|READERS| + '(|PORT|::|CODE-ARGS|) :|INITFORM| + '#3=(|COMMON-LISP|::|LIST| (|COMMON-LISP|::|LISP-IMPLEMENTATION-TYPE|) + (|COMMON-LISP|::|LISP-IMPLEMENTATION-VERSION|)) + :|INITFUNCTION| + (|COMMON-LISP|::|FUNCTION| |PORT|::|DEFAULT-ARGS| + (|COMMON-LISP|::|LAMBDA| |COMMON-LISP|::|NIL| #3#)) + :|TYPE| '|COMMON-LISP|::|LIST|)) + :|METACLASS| #1# :|DOCUMENTATION| + '"Your implementation does not support this functionality." + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|GENERIC-ACCESSORS| '|COMMON-LISP|::|T|)))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|CODE-MESG| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|CODE-ARGS| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|PORT|::|WITH-GENSYMS|) +(|SYSTEM|::|%PUTD| '|PORT|::|WITH-GENSYMS| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |PORT|::|WITH-GENSYMS| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + "Bind symbols in NAMES to gensyms. TITLE is a string - `gensym' prefix.\n +Inspired by Paul Graham, , p. 145." + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 2. 2. + |COMMON-LISP|::|T|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((#1=#:|G47080| (|COMMON-LISP|::|CADR| . #2=(|SYSTEM|::||))) + (#3=#:|G47081| + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| #1# 1. 1. |COMMON-LISP|::|T|)) + (|SYSTEM|::|ERROR-OF-TYPE| '|EXT|::|SOURCE-PROGRAM-ERROR| :|FORM| + |SYSTEM|::|| :|DETAIL| #1# + (|SYSTEM|::|TEXT| "~S: ~S does not match lambda list element ~:S") + '|PORT|::|WITH-GENSYMS| #1# + '#4=(|PORT|::|TITLE| |COMMON-LISP|::|&REST| |PORT|::|NAMES|)) + #1#)) + (|PORT|::|TITLE| (|COMMON-LISP|::|CAR| #3#)) + (|PORT|::|NAMES| (|COMMON-LISP|::|CDR| #3#)) + (|PORT|::|BODY| (|COMMON-LISP|::|CDDR| . #2#))) + (|COMMON-LISP|::|BLOCK| |PORT|::|WITH-GENSYMS| + `(|COMMON-LISP|::|LET| + (,@(|COMMON-LISP|::|MAPCAR| + (|COMMON-LISP|::|LAMBDA| (|PORT|::|SY|) + `(,|PORT|::|SY| + (|COMMON-LISP|::|GENSYM| + ,(|COMMON-LISP|::|CONCATENATE| '|COMMON-LISP|::|STRING| + |PORT|::|TITLE| (|COMMON-LISP|::|SYMBOL-NAME| |PORT|::|SY|) + "-")))) + |PORT|::|NAMES|)) + ,@|PORT|::|BODY|)))))) + '(#4# |COMMON-LISP|::|&BODY| |PORT|::|BODY|))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|PORT|::|DEFCONST|) +(|SYSTEM|::|%PUTD| '|PORT|::|DEFCONST| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |PORT|::|DEFCONST| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + "Define a typed constant." + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 5. 5. + |COMMON-LISP|::|NIL|)) + (|SYSTEM|::|MACRO-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| + ((|PORT|::|NAME| (|COMMON-LISP|::|CADR| . #1=(|SYSTEM|::||))) + (|COMMON-LISP|::|TYPE| (|COMMON-LISP|::|CADDR| . #1#)) + (|PORT|::|INIT| (|COMMON-LISP|::|CADDDR| . #1#)) + (|PORT|::|DOC| (|COMMON-LISP|::|FIFTH| . #1#))) + (|COMMON-LISP|::|BLOCK| |PORT|::|DEFCONST| + `(|COMMON-LISP|::|PROGN| + (|COMMON-LISP|::|DECLAIM| + (|COMMON-LISP|::|TYPE| ,|COMMON-LISP|::|TYPE| ,|PORT|::|NAME|)) + (,(|COMMON-LISP|::|IF| + (|COMMON-LISP|::|SUBTYPEP| |COMMON-LISP|::|TYPE| + '(|COMMON-LISP|::|OR| |COMMON-LISP|::|SYMBOL| + |COMMON-LISP|::|NUMBER| |COMMON-LISP|::|CHARACTER|)) + '|COMMON-LISP|::|DEFCONSTANT| '|COMMON-LISP|::|DEFVAR|) + ,|PORT|::|NAME| + (|COMMON-LISP|::|THE| ,|COMMON-LISP|::|TYPE| ,|PORT|::|INIT|) + ,|PORT|::|DOC|))))))) + '(|PORT|::|NAME| |COMMON-LISP|::|TYPE| |PORT|::|INIT| |PORT|::|DOC|))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|TYPE| |COMMON-LISP|::|CONS| |PORT|::|+EOF+|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|SPECIAL| |PORT|::|+EOF+|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|STRING-TOKENS| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|STRING| |COMMON-LISP|::|&KEY| (|PORT|::|START| 0.) + |PORT|::|END| |COMMON-LISP|::|MAX| + ((:|PACKAGE| |COMMON-LISP|::|*PACKAGE*|) + (|COMMON-LISP|::|FIND-PACKAGE| :|KEYWORD|))))) +(|SYSTEM|::|REMOVE-OLD-DEFINITIONS| '|PORT|::|COMPOSE|) +(|SYSTEM|::|%PUTD| '|PORT|::|COMPOSE| + (|SYSTEM|::|MAKE-MACRO| + (|COMMON-LISP|::|FUNCTION| |PORT|::|COMPOSE| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::|| |SYSTEM|::||) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|CONS| |SYSTEM|::||)) + (|COMMON-LISP|::|DECLARE| (|COMMON-LISP|::|IGNORE| |SYSTEM|::||)) + "Macro: compose functions or macros of 1 argument into a lambda.\n +E.g., (compose abs (dl-val zz) 'key) ==>\n + (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))" + (|COMMON-LISP|::|LET*| + ((|PORT|::|FUNCTIONS| (|COMMON-LISP|::|CDR| |SYSTEM|::||))) + (|COMMON-LISP|::|BLOCK| |PORT|::|COMPOSE| + (|COMMON-LISP|::|LABELS| + ((|PORT|::|REC| (|PORT|::|XX| |PORT|::|YY|) + (|COMMON-LISP|::|LET| + ((|PORT|::|RR| + (|COMMON-LISP|::|LIST| (|COMMON-LISP|::|CAR| |PORT|::|XX|) + (|COMMON-LISP|::|IF| (|COMMON-LISP|::|CDR| |PORT|::|XX|) + (|PORT|::|REC| (|COMMON-LISP|::|CDR| |PORT|::|XX|) |PORT|::|YY|) + |PORT|::|YY|)))) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|CONSP| (|COMMON-LISP|::|CAR| |PORT|::|XX|)) + (|COMMON-LISP|::|CONS| '|COMMON-LISP|::|FUNCALL| + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|EQ| (|COMMON-LISP|::|CAAR| |PORT|::|XX|) + '|COMMON-LISP|::|QUOTE|) + (|COMMON-LISP|::|CONS| (|COMMON-LISP|::|CADAR| |PORT|::|XX|) + (|COMMON-LISP|::|CDR| |PORT|::|RR|)) + |PORT|::|RR|)) + |PORT|::|RR|)))) + (|PORT|::|WITH-GENSYMS| ("COMPOSE-" |PORT|::|ARG|) + `(|COMMON-LISP|::|LAMBDA| (,|PORT|::|ARG|) + ,(|PORT|::|REC| |PORT|::|FUNCTIONS| |PORT|::|ARG|)))))))) + '(|COMMON-LISP|::|&REST| |PORT|::|FUNCTIONS|))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| ((|COMMON-LISP|::|UNSIGNED-BYTE| 32.)) + (|COMMON-LISP|::|VALUES| |COMMON-LISP|::|SIMPLE-STRING|)) + |PORT|::|IPADDR-TO-DOTTED|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|IPADDR-TO-DOTTED| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|IPADDR|))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FTYPE| + (|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|STRING|) + (|COMMON-LISP|::|VALUES| (|COMMON-LISP|::|UNSIGNED-BYTE| 32.))) + |PORT|::|DOTTED-TO-IPADDR|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|DOTTED-TO-IPADDR| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|DOTTED|))) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|LET| + ((#1=#:|G47213| + (|COMMON-LISP|::|CONS| '|PORT|::|HOSTENT| + (|CLOS|::|CLASS-NAMES| + (|COMMON-LISP|::|GET| '|COMMON-LISP|::|STRUCTURE-OBJECT| + '|CLOS|::|CLOSCLASS|))))) + (|SYSTEM|::|STRUCTURE-UNDEFINE-ACCESSORIES| '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|REMPROP| '|PORT|::|HOSTENT| + '|SYSTEM|::|DEFSTRUCT-DESCRIPTION|) + (|CLOS|::|DEFINE-STRUCTURE-CLASS| '|PORT|::|HOSTENT| #1# + '|PORT|::|MAKE-HOSTENT| '|COMMON-LISP|::|NIL| '|PORT|::|COPY-HOSTENT| + '|PORT|::|HOSTENT-P| + (|COMMON-LISP|::|LIST| + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|NAME| + :|INITARGS| '#2=(:|NAME|) :|TYPE| '|COMMON-LISP|::|SIMPLE-STRING| + :|ALLOCATION| ':|INSTANCE| #3='|CLOS|::|INHERITABLE-INITER| + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#4="" + #5=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| #4#)) + #6='|CLOS|::|INHERITABLE-DOC| '(|COMMON-LISP|::|NIL|) + #7='|CLOS|::|LOCATION| '1. #8='|CLOS|::|READONLY| '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|ALIASES| + :|INITARGS| '#9=(:|ALIASES|) :|TYPE| '|COMMON-LISP|::|LIST| :|ALLOCATION| + ':|INSTANCE| #3# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #10=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|)) + #6# '(|COMMON-LISP|::|NIL|) #7# '2. #8# '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|PORT|::|ADDR-LIST| :|INITARGS| '#11=(:|ADDR-LIST|) :|TYPE| + '|COMMON-LISP|::|LIST| :|ALLOCATION| ':|INSTANCE| #3# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #12=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|)) + #6# '(|COMMON-LISP|::|NIL|) #7# '3. #8# '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| + '|PORT|::|ADDR-TYPE| :|INITARGS| '#13=(:|ADDR-TYPE|) :|TYPE| + '|COMMON-LISP|::|FIXNUM| :|ALLOCATION| ':|INSTANCE| #3# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '2. + #14=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| 2.)) + #6# '(|COMMON-LISP|::|NIL|) #7# '4. #8# '|COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|LIST| + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|NAME| + :|INITARGS| '#2# :|TYPE| '|COMMON-LISP|::|SIMPLE-STRING| :|ALLOCATION| + ':|INSTANCE| #15='|CLOS|::|INHERITABLE-INITER| + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#4# #5#) + #16='|CLOS|::|INHERITABLE-DOC| '(|COMMON-LISP|::|NIL|) :|READERS| + '(|PORT|::|HOSTENT-NAME|) :|WRITERS| + '((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|ALIASES| + :|INITARGS| '#9# :|TYPE| '|COMMON-LISP|::|LIST| :|ALLOCATION| ':|INSTANCE| + #15# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #10#) + #16# '(|COMMON-LISP|::|NIL|) :|READERS| '(|PORT|::|HOSTENT-ALIASES|) + :|WRITERS| '((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|ADDR-LIST| + :|INITARGS| '#11# :|TYPE| '|COMMON-LISP|::|LIST| :|ALLOCATION| + ':|INSTANCE| #15# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #12#) + #16# '(|COMMON-LISP|::|NIL|) :|READERS| '(|PORT|::|HOSTENT-ADDR-LIST|) + :|WRITERS| '((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|ADDR-TYPE| + :|INITARGS| '#13# :|TYPE| '|COMMON-LISP|::|FIXNUM| :|ALLOCATION| + ':|INSTANCE| #15# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '2. #14#) #16# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|PORT|::|HOSTENT-ADDR-TYPE|) + :|WRITERS| '((|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|))))) + (|COMMON-LISP|::|DEFUN| |PORT|::|MAKE-HOSTENT| + (|COMMON-LISP|::|&KEY| (#17=#:|NAME| #4#) + (#18=#:|ALIASES| |COMMON-LISP|::|NIL|) + (#19=#:|ADDR-LIST| |COMMON-LISP|::|NIL|) (#20=#:|ADDR-TYPE| 2.)) + (|COMMON-LISP|::|LET| + ((|SYSTEM|::|OBJECT| (|SYSTEM|::|%MAKE-STRUCTURE| #1# 5.))) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| #17#)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| #18#)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| #19#)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| #20#)) + |SYSTEM|::|OBJECT|))) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-P|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|HOSTENT-P| (|SYSTEM|::|OBJECT|) + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|COPY-HOSTENT|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|COPY-HOSTENT| (|COMMON-LISP|::|STRUCTURE|) + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-NAME| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-NAME|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|HOSTENT-NAME| #21=(|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1.))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-NAME| #22='|SYSTEM|::|DEFSTRUCT-READER| + '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ALIASES| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ALIASES|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|HOSTENT-ALIASES| #21# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2.))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-ALIASES| #22# '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ADDR-LIST| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ADDR-LIST|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|HOSTENT-ADDR-LIST| #21# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3.))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-ADDR-LIST| #22# '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ADDR-TYPE| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|FIXNUM|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ADDR-TYPE|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|HOSTENT-ADDR-TYPE| #21# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4.))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-ADDR-TYPE| #22# '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|) + (|COMMON-LISP|::|SIMPLE-STRING| |PORT|::|HOSTENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|) + #23=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| . + #24=(|SYSTEM|::|VALUE|)))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-NAME| #25='|SYSTEM|::|DEFSTRUCT-WRITER| + '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|) + (|COMMON-LISP|::|LIST| |PORT|::|HOSTENT|) |COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|) #23# + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| . #24#))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-ALIASES| #25# '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|) + (|COMMON-LISP|::|LIST| |PORT|::|HOSTENT|) |COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|) + #23# + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| . #24#))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-ADDR-LIST| #25# '|PORT|::|HOSTENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|) + (|COMMON-LISP|::|FIXNUM| |PORT|::|HOSTENT|) |COMMON-LISP|::|FIXNUM|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|) + #23# + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| . #24#))) + (|SYSTEM|::|%PUT| '|PORT|::|HOSTENT-ADDR-TYPE| #25# '|PORT|::|HOSTENT|) + (|SYSTEM|::|%SET-DOCUMENTATION| '|PORT|::|HOSTENT| '|COMMON-LISP|::|TYPE| + "see gethostbyname(3) for details") + (|CLOS|::|DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD| '|PORT|::|HOSTENT|) + '|PORT|::|HOSTENT|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|MAKE-HOSTENT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&KEY| (#:|NAME| "") (#:|ALIASES| |COMMON-LISP|::|NIL|) + (#:|ADDR-LIST| |COMMON-LISP|::|NIL|) (#:|ADDR-TYPE| 2.)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-P|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|HOSTENT-P| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-P|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-P| + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT|)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|COPY-HOSTENT|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|COPY-HOSTENT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|COMMON-LISP|::|STRUCTURE|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|COPY-HOSTENT|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|COPY-HOSTENT| + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|)))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-NAME| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-NAME|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|HOSTENT-NAME| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-NAME|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-NAME| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ALIASES| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|LIST|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ALIASES|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|HOSTENT-ALIASES| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-ALIASES|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ALIASES| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ADDR-LIST| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|LIST|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ADDR-LIST|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|HOSTENT-ADDR-LIST| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-ADDR-LIST|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-LIST| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|HOSTENT-ADDR-TYPE| (|PORT|::|HOSTENT|) + |COMMON-LISP|::|FIXNUM|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|HOSTENT-ADDR-TYPE|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|HOSTENT-ADDR-TYPE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| + (|SYSTEM|::|IN-DEFUN| |PORT|::|HOSTENT-ADDR-TYPE|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-TYPE| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|) + (|COMMON-LISP|::|SIMPLE-STRING| |PORT|::|HOSTENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-NAME|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-NAME| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 1. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|) + (|COMMON-LISP|::|LIST| |PORT|::|HOSTENT|) |COMMON-LISP|::|LIST|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ALIASES|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ALIASES| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|) + (|COMMON-LISP|::|LIST| |PORT|::|HOSTENT|) |COMMON-LISP|::|LIST|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-LIST|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-LIST| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 3. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|) + (|COMMON-LISP|::|FIXNUM| |PORT|::|HOSTENT|) |COMMON-LISP|::|FIXNUM|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| + (|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|HOSTENT-ADDR-TYPE|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|HOSTENT-ADDR-TYPE| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|HOSTENT| |SYSTEM|::|OBJECT| 4. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|RESOLVE-HOST-IPADDR| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|HOST|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|IPADDR-CLOSURE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|ADDRESS|))) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|SYSTEM|::|%PUT| '|PORT|::|SOCKET| '|SYSTEM|::|DEFTYPE-EXPANDER| + (|COMMON-LISP|::|FUNCTION| #:|DEFTYPE-SOCKET| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::||) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 1. + 1.)) + (|SYSTEM|::|TYPE-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|BLOCK| |PORT|::|SOCKET| '|COMMON-LISP|::|STREAM|)))))) + (|SYSTEM|::|%SET-DOCUMENTATION| '|PORT|::|SOCKET| '|COMMON-LISP|::|TYPE| + '|COMMON-LISP|::|NIL|) + '|PORT|::|SOCKET|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|OPEN-SOCKET| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|PORT|::|HOST| |PORT|::|PORT| |COMMON-LISP|::|&OPTIONAL| |PORT|::|BIN|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SET-SOCKET-STREAM-FORMAT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|PORT|::|SOCKET| |COMMON-LISP|::|FORMAT|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SOCKET-HOST/PORT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|SOCK|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SOCKET-STRING| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|SOCK|))) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|SYSTEM|::|%PUT| '|PORT|::|SOCKET-SERVER| '|SYSTEM|::|DEFTYPE-EXPANDER| + (|COMMON-LISP|::|FUNCTION| #:|DEFTYPE-SOCKET-SERVER| + (|COMMON-LISP|::|LAMBDA| (|SYSTEM|::||) + (|COMMON-LISP|::|IF| + (|COMMON-LISP|::|NOT| + (|SYSTEM|::|PROPER-LIST-LENGTH-IN-BOUNDS-P| |SYSTEM|::|| 1. + 1.)) + (|SYSTEM|::|TYPE-CALL-ERROR| |SYSTEM|::||) + (|COMMON-LISP|::|LET*| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|BLOCK| |PORT|::|SOCKET-SERVER| + '|SOCKET|::|SOCKET-SERVER|)))))) + (|SYSTEM|::|%SET-DOCUMENTATION| '|PORT|::|SOCKET-SERVER| + '|COMMON-LISP|::|TYPE| '|COMMON-LISP|::|NIL|) + '|PORT|::|SOCKET-SERVER|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|OPEN-SOCKET-SERVER| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&OPTIONAL| |PORT|::|PORT|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SOCKET-ACCEPT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|PORT|::|SERV| |COMMON-LISP|::|&KEY| |PORT|::|BIN| |PORT|::|WAIT|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SOCKET-SERVER-CLOSE| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|SERVER|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SOCKET-SERVER-HOST/PORT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|SERVER|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|WAIT-FOR-STREAM| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|STREAM| |COMMON-LISP|::|&OPTIONAL| |PORT|::|TIMEOUT|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|OPEN-UNIX-SOCKET| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|PORT|::|PATH| |COMMON-LISP|::|&KEY| (|PORT|::|KIND| :|STREAM|) + |PORT|::|BIN|))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|REPORT-NETWORK-CONDITION| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '(|PORT|::|CC| |PORT|::|OUT|))) +(|COMMON-LISP|::|LET*| ((#1=#:|G47479| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|NETWORK| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|COMMON-LISP|::|ERROR|) + :|DIRECT-SLOTS| + (|COMMON-LISP|::|LIST| + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|PROC| :|READERS| + '(|PORT|::|NET-PROC|) :|INITARGS| '(:|PROC|) :|INITFORM| + '|COMMON-LISP|::|NIL| :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|) :|TYPE| + '|COMMON-LISP|::|SYMBOL|) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|HOST| :|READERS| + '(|PORT|::|NET-HOST|) :|INITARGS| '(:|HOST|) :|INITFORM| '#2="" + :|INITFUNCTION| (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| #2#) :|TYPE| + '|COMMON-LISP|::|SIMPLE-STRING|) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|PORT| :|READERS| + '(|PORT|::|NET-PORT|) :|INITARGS| '(:|PORT|) :|INITFORM| '0. + :|INITFUNCTION| (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| 0.) :|TYPE| + '(|COMMON-LISP|::|UNSIGNED-BYTE| 16.)) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|MESG| :|READERS| + '(|PORT|::|NET-MESG|) :|INITARGS| '(:|MESG|) :|INITFORM| + '|COMMON-LISP|::|NIL| :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|) :|TYPE| + '(|COMMON-LISP|::|OR| |COMMON-LISP|::|NULL| + |COMMON-LISP|::|SIMPLE-STRING|)) + (|COMMON-LISP|::|LIST| :|NAME| '|PORT|::|ARGS| :|READERS| + '(|PORT|::|NET-ARGS|) :|INITARGS| '(:|ARGS|) :|INITFORM| + '|COMMON-LISP|::|NIL| :|INITFUNCTION| + (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|) :|TYPE| + '|COMMON-LISP|::|LIST|)) + :|METACLASS| #1# + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|DOCUMENTATION| |COMMON-LISP|::|NIL| :|GENERIC-ACCESSORS| + '|COMMON-LISP|::|T|)))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|NET-PROC| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|NET-HOST| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|NET-PORT| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|NET-MESG| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|NET-ARGS| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|CLOS|::|PRINT-OBJECT| + #(2. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|COMMON-LISP|::|LET*| ((#1=#:|G47552| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|TIMEOUT| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|PORT|::|NETWORK|) + :|DIRECT-SLOTS| + (|COMMON-LISP|::|LIST| + (|COMMON-LISP|::|LIST| :|NAME| '|COMMON-LISP|::|TIME| :|READERS| + '(|PORT|::|TIMEOUT-TIME|) :|INITARGS| '(:|TIME|) :|INITFORM| '0. + :|INITFUNCTION| (|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| 0.) :|TYPE| + '(|COMMON-LISP|::|REAL| 0.))) + :|METACLASS| #1# + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|DOCUMENTATION| |COMMON-LISP|::|NIL| :|GENERIC-ACCESSORS| + '|COMMON-LISP|::|T|)))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|TIMEOUT-TIME| + #(1. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|SYSTEM|::|C-DEFUN| '|CLOS|::|PRINT-OBJECT| + #(2. 0. |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| |COMMON-LISP|::|NIL| + |COMMON-LISP|::|NIL|) + |COMMON-LISP|::|NIL| '|CLOS|::|DEFMETHOD|) +(|COMMON-LISP|::|LET*| ((#1=#:|G47608| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|LOGIN| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|PORT|::|NETWORK|) + :|DIRECT-SLOTS| (|COMMON-LISP|::|LIST|) :|METACLASS| #1# + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|DOCUMENTATION| |COMMON-LISP|::|NIL| :|GENERIC-ACCESSORS| + '|COMMON-LISP|::|T|)))) +(|COMMON-LISP|::|LET*| ((#1=#:|G47612| |CLOS|::||)) + (|COMMON-LISP|::|APPLY| #'|CLOS|::|ENSURE-CLASS| '|PORT|::|NET-PATH| + :|DIRECT-SUPERCLASSES| (|COMMON-LISP|::|LIST| '|PORT|::|NETWORK|) + :|DIRECT-SLOTS| (|COMMON-LISP|::|LIST|) :|METACLASS| #1# + (|COMMON-LISP|::|APPEND| '(:|FIXED-SLOT-LOCATIONS| |COMMON-LISP|::|NIL|) + (|COMMON-LISP|::|LIST| :|DIRECT-DEFAULT-INITARGS| |COMMON-LISP|::|NIL| + :|DOCUMENTATION| |COMMON-LISP|::|NIL| :|GENERIC-ACCESSORS| + '|COMMON-LISP|::|T|)))) +(|COMMON-LISP|::|LET| |COMMON-LISP|::|NIL| + (|COMMON-LISP|::|LET| + ((#1=#:|G47616| + (|COMMON-LISP|::|CONS| '|PORT|::|SERVENT| + (|CLOS|::|CLASS-NAMES| + (|COMMON-LISP|::|GET| '|COMMON-LISP|::|STRUCTURE-OBJECT| + '|CLOS|::|CLOSCLASS|))))) + (|SYSTEM|::|STRUCTURE-UNDEFINE-ACCESSORIES| '|PORT|::|SERVENT|) + (|COMMON-LISP|::|REMPROP| '|PORT|::|SERVENT| + '|SYSTEM|::|DEFSTRUCT-DESCRIPTION|) + (|CLOS|::|DEFINE-STRUCTURE-CLASS| '|PORT|::|SERVENT| #1# + '|PORT|::|MAKE-SERVENT| '|COMMON-LISP|::|NIL| '|PORT|::|COPY-SERVENT| + '|PORT|::|SERVENT-P| + (|COMMON-LISP|::|LIST| + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|NAME| + :|INITARGS| '#2=(:|NAME|) :|TYPE| '|COMMON-LISP|::|SIMPLE-STRING| + :|ALLOCATION| ':|INSTANCE| #3='|CLOS|::|INHERITABLE-INITER| + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#4="" + #5=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| #4#)) + #6='|CLOS|::|INHERITABLE-DOC| '(|COMMON-LISP|::|NIL|) + #7='|CLOS|::|LOCATION| '1. #8='|CLOS|::|READONLY| '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|ALIASES| + :|INITARGS| '#9=(:|ALIASES|) :|TYPE| '|COMMON-LISP|::|LIST| :|ALLOCATION| + ':|INSTANCE| #3# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #10=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| |COMMON-LISP|::|NIL|)) + #6# '(|COMMON-LISP|::|NIL|) #7# '2. #8# '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|PORT| + :|INITARGS| '#11=(:|PORT|) :|TYPE| '|COMMON-LISP|::|FIXNUM| :|ALLOCATION| + ':|INSTANCE| #3# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '-1. + #12=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| -1.)) + #6# '(|COMMON-LISP|::|NIL|) #7# '3. #8# '|COMMON-LISP|::|NIL|) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|PROTO| + :|INITARGS| '#13=(:|PROTO|) :|TYPE| '|COMMON-LISP|::|SYMBOL| :|ALLOCATION| + ':|INSTANCE| #3# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| ':|TCP| + #14=(|SYSTEM|::|MAKE-CONSTANT-INITFUNCTION| :|TCP|)) + #6# '(|COMMON-LISP|::|NIL|) #7# '4. #8# '|COMMON-LISP|::|NIL|)) + (|COMMON-LISP|::|LIST| + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|NAME| + :|INITARGS| '#2# :|TYPE| '|COMMON-LISP|::|SIMPLE-STRING| :|ALLOCATION| + ':|INSTANCE| #15='|CLOS|::|INHERITABLE-INITER| + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '#4# #5#) + #16='|CLOS|::|INHERITABLE-DOC| '(|COMMON-LISP|::|NIL|) :|READERS| + '(|PORT|::|SERVENT-NAME|) :|WRITERS| + '((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|ALIASES| + :|INITARGS| '#9# :|TYPE| '|COMMON-LISP|::|LIST| :|ALLOCATION| ':|INSTANCE| + #15# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '|COMMON-LISP|::|NIL| + #10#) + #16# '(|COMMON-LISP|::|NIL|) :|READERS| '(|PORT|::|SERVENT-ALIASES|) + :|WRITERS| '((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|PORT| + :|INITARGS| '#11# :|TYPE| '|COMMON-LISP|::|FIXNUM| :|ALLOCATION| + ':|INSTANCE| #15# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| '-1. #12#) #16# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|PORT|::|SERVENT-PORT|) :|WRITERS| + '((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|))) + (|CLOS|::|MAKE-INSTANCE-| + |CLOS|::|| :|NAME| '|PORT|::|PROTO| + :|INITARGS| '#13# :|TYPE| '|COMMON-LISP|::|SYMBOL| :|ALLOCATION| + ':|INSTANCE| #15# + (|CLOS|::|MAKE-INHERITABLE-SLOT-DEFINITION-INITER| ':|TCP| #14#) #16# + '(|COMMON-LISP|::|NIL|) :|READERS| '(|PORT|::|SERVENT-PROTO|) :|WRITERS| + '((|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|))))) + (|COMMON-LISP|::|DEFUN| |PORT|::|MAKE-SERVENT| + (|COMMON-LISP|::|&KEY| (#17=#:|NAME| #4#) + (#18=#:|ALIASES| |COMMON-LISP|::|NIL|) (#19=#:|PORT| -1.) + (#20=#:|PROTO| :|TCP|)) + (|COMMON-LISP|::|LET| + ((|SYSTEM|::|OBJECT| (|SYSTEM|::|%MAKE-STRUCTURE| #1# 5.))) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| #17#)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| #18#)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| #19#)) + (|COMMON-LISP|::|SETF| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4.) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| #20#)) + |SYSTEM|::|OBJECT|))) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-P|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|SERVENT-P| (|SYSTEM|::|OBJECT|) + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|COPY-SERVENT|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|COPY-SERVENT| (|COMMON-LISP|::|STRUCTURE|) + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-NAME| (|PORT|::|SERVENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-NAME|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|SERVENT-NAME| #21=(|SYSTEM|::|OBJECT|) + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1.))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-NAME| #22='|SYSTEM|::|DEFSTRUCT-READER| + '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-ALIASES| (|PORT|::|SERVENT|) + |COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-ALIASES|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|SERVENT-ALIASES| #21# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2.))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-ALIASES| #22# '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-PORT| (|PORT|::|SERVENT|) + |COMMON-LISP|::|FIXNUM|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-PORT|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|SERVENT-PORT| #21# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3.))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-PORT| #22# '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-PROTO| (|PORT|::|SERVENT|) + |COMMON-LISP|::|SYMBOL|)) + (|COMMON-LISP|::|PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-PROTO|)) + (|COMMON-LISP|::|DEFUN| |PORT|::|SERVENT-PROTO| #21# + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4.))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-PROTO| #22# '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|) + (|COMMON-LISP|::|SIMPLE-STRING| |PORT|::|SERVENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|) + #23=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|) + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| . + #24=(|SYSTEM|::|VALUE|)))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-NAME| #25='|SYSTEM|::|DEFSTRUCT-WRITER| + '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|) + (|COMMON-LISP|::|LIST| |PORT|::|SERVENT|) |COMMON-LISP|::|LIST|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|) #23# + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| . #24#))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-ALIASES| #25# '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|) + (|COMMON-LISP|::|FIXNUM| |PORT|::|SERVENT|) |COMMON-LISP|::|FIXNUM|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|) #23# + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| . #24#))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-PORT| #25# '|PORT|::|SERVENT|) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|) + (|COMMON-LISP|::|SYMBOL| |PORT|::|SERVENT|) |COMMON-LISP|::|SYMBOL|)) + (|COMMON-LISP|::|PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|))) + (|COMMON-LISP|::|DEFUN| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|) #23# + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| . #24#))) + (|SYSTEM|::|%PUT| '|PORT|::|SERVENT-PROTO| #25# '|PORT|::|SERVENT|) + (|SYSTEM|::|%SET-DOCUMENTATION| '|PORT|::|SERVENT| '|COMMON-LISP|::|TYPE| + "see getservbyname(3) for details") + (|CLOS|::|DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD| '|PORT|::|SERVENT|) + '|PORT|::|SERVENT|) +(|SYSTEM|::|C-DEFUN| '|PORT|::|MAKE-SERVENT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&KEY| (#:|NAME| "") (#:|ALIASES| |COMMON-LISP|::|NIL|) + (#:|PORT| -1.) (#:|PROTO| :|TCP|)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-P|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SERVENT-P| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-P|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-P| + (|SYSTEM|::|%STRUCTURE-TYPE-P| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT|)))) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|COPY-SERVENT|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|COPY-SERVENT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|COMMON-LISP|::|STRUCTURE|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|COPY-SERVENT|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|COPY-SERVENT| + (|COMMON-LISP|::|COPY-STRUCTURE| |COMMON-LISP|::|STRUCTURE|)))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-NAME| (|PORT|::|SERVENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-NAME|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SERVENT-NAME| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-NAME|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-NAME| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-ALIASES| (|PORT|::|SERVENT|) + |COMMON-LISP|::|LIST|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-ALIASES|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SERVENT-ALIASES| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-ALIASES|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-ALIASES| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-PORT| (|PORT|::|SERVENT|) + |COMMON-LISP|::|FIXNUM|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-PORT|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SERVENT-PORT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-PORT|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PORT| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| |PORT|::|SERVENT-PROTO| (|PORT|::|SERVENT|) + |COMMON-LISP|::|SYMBOL|)) +(|SYSTEM|::|C-PROCLAIM| '(|COMMON-LISP|::|INLINE| |PORT|::|SERVENT-PROTO|)) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SERVENT-PROTO| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| '#1=(|SYSTEM|::|OBJECT|)) + '(#1# + (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| |PORT|::|SERVENT-PROTO|)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PROTO| + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| + (|SYSTEM|::|%STRUCTURE-REF| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4.))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|) + (|COMMON-LISP|::|SIMPLE-STRING| |PORT|::|SERVENT|) + |COMMON-LISP|::|SIMPLE-STRING|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-NAME|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-NAME| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 1. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SIMPLE-STRING| + |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|) + (|COMMON-LISP|::|LIST| |PORT|::|SERVENT|) |COMMON-LISP|::|LIST|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-ALIASES|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-ALIASES| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 2. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|LIST| |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|) + (|COMMON-LISP|::|FIXNUM| |PORT|::|SERVENT|) |COMMON-LISP|::|FIXNUM|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PORT|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PORT| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 3. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|FIXNUM| |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|FUNCTION| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|) + (|COMMON-LISP|::|SYMBOL| |PORT|::|SERVENT|) |COMMON-LISP|::|SYMBOL|)) +(|SYSTEM|::|C-PROCLAIM| + '(|COMMON-LISP|::|INLINE| (|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|))) +(|SYSTEM|::|C-DEFUN| '#1=(|COMMON-LISP|::|SETF| |PORT|::|SERVENT-PROTO|) + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '#2=(|SYSTEM|::|VALUE| |SYSTEM|::|OBJECT|)) + '(#2# (|COMMON-LISP|::|DECLARE| (|SYSTEM|::|IN-DEFUN| #1#)) + (|COMMON-LISP|::|BLOCK| |PORT|::|SERVENT-PROTO| + (|SYSTEM|::|%STRUCTURE-STORE| '|PORT|::|SERVENT| |SYSTEM|::|OBJECT| 4. + (|COMMON-LISP|::|THE| |COMMON-LISP|::|SYMBOL| |SYSTEM|::|VALUE|))))) +(|SYSTEM|::|C-DEFUN| '|PORT|::|SOCKET-SERVICE-PORT| + (|SYSTEM|::|LAMBDA-LIST-TO-SIGNATURE| + '(|COMMON-LISP|::|&OPTIONAL| |PORT|::|SERVICE| (|PORT|::|PROTOCOL| "tcp")))) +(|SYSTEM|::|C-PROVIDE| ':|PORT-NET|) Added: clfswm/contrib/server/net.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/net.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,781 @@ +;;; Network Access +;;; +;;; Copyright (C) 1999-2008 by Sam Steingold +;;; This is open-source software. +;;; GNU Lesser General Public License (LGPL) is applicable: +;;; No warranty; you may copy/modify/redistribute under the same +;;; conditions with the source code. +;;; See +;;; for details and the precise copyright document. +;;; +;;; $Id: net.lisp,v 1.64 2008/10/20 19:54:38 sds Exp $ +;;; $Source: /cvsroot-fuse/clocc/clocc/src/port/net.lisp,v $ + +(in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;(require "ext.lisp") + ;; `getenv' + ;;(require "sys.lisp") + #+(or cmu scl) (require :simple-streams) ; for `set-socket-stream-format' + #+cormanlisp (require :winsock) + #+lispworks (require "comm") + #+(and sbcl (not (or db-sockets net.sbcl.sockets))) + (progn (require :sb-bsd-sockets) (pushnew :sb-bsd-sockets *features*))) + +(defpackage :port + (:use :common-lisp) + (:export :resolve-host-ipaddr + :ipaddr-to-dotted + :dotted-to-ipaddr + :ipaddr-closure + :hostent + :hostent-name + :hostent-aliases + :hostent-addr-list + :hostent-addr-type + :socket + :open-socket + :socket-host/port + :socket-string + :socket-server + :set-socket-stream-format + :socket-accept + :open-socket-server + :socket-server-close + :socket-server-host/port + :socket-service-port + :servent-name + :servent-aliases + :servent-port + :servent-proto + :servent-p + :servent + :network + :timeout + :login + :net-path)) + +(in-package :port) + + +(define-condition code (error) + ((proc :reader code-proc :initarg :proc :initform nil) + (mesg :type (or null simple-string) :reader code-mesg + :initarg :mesg :initform nil) + (args :type list :reader code-args :initarg :args :initform nil)) + (:documentation "An error in the user code.") + (:report (lambda (cc out) + (declare (stream out)) + (format out "[~s]~@[ ~?~]" (code-proc cc) (code-mesg cc) + (code-args cc))))) + +(define-condition case-error (code) + ((mesg :type simple-string :reader code-mesg :initform + "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]")) + (:documentation "An error in a case statement. +This carries the function name which makes the error message more useful.")) + + +(define-condition not-implemented (code) + ((mesg :type simple-string :reader code-mesg :initform + "not implemented for ~a [~a]") + (args :type list :reader code-args :initform + (list (lisp-implementation-type) (lisp-implementation-version)))) + (:documentation "Your implementation does not support this functionality.")) + + +(defmacro with-gensyms ((title &rest names) &body body) + "Bind symbols in NAMES to gensyms. TITLE is a string - `gensym' prefix. +Inspired by Paul Graham, , p. 145." + `(let (,@(mapcar (lambda (sy) + `(,sy (gensym ,(concatenate 'string title + (symbol-name sy) "-")))) + names)) + , at body)) + +(defmacro defconst (name type init doc) + "Define a typed constant." + `(progn (declaim (type ,type ,name)) + ;; since constant redefinition must be the same under EQL, there + ;; can be no constants other than symbols, numbers and characters + ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables" + (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar) + ,name (the ,type ,init) ,doc))) + +(defconst +eof+ cons (list '+eof+) + "*The end-of-file object. +To be passed as the third arg to `read' and checked against using `eq'.") + +(defun string-tokens (string &key (start 0) end max + ((:package *package*) (find-package :keyword))) + "Read from STRING repeatedly, starting with START, up to MAX tokens. +Return the list of objects read and the final index in STRING. +Binds `*package*' to the KEYWORD package (or argument), +so that the bare symbols are read as keywords." + (declare (type (or null fixnum) max) (type fixnum start)) + (if max + (do ((beg start) obj res (num 0 (1+ num))) + ((or (= max num) (and end (>= beg end))) + (values (nreverse res) beg)) + (declare (fixnum beg num)) + (setf (values obj beg) + (read-from-string string nil +eof+ :start beg :end end)) + (if (eq obj +eof+) + (return (values (nreverse res) beg)) + (push obj res))) + (with-input-from-string (st string :start start :end end) + (loop :for obj = (read st nil st) + :until (eq obj st) :collect obj)))) + + + +(defmacro compose (&rest functions) + "Macro: compose functions or macros of 1 argument into a lambda. +E.g., (compose abs (dl-val zz) 'key) ==> + (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))" + (labels ((rec (xx yy) + (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy)))) + (if (consp (car xx)) + (cons 'funcall (if (eq (caar xx) 'quote) + (cons (cadar xx) (cdr rr)) rr)) + rr)))) + (with-gensyms ("COMPOSE-" arg) + `(lambda (,arg) ,(rec functions arg))))) + + + + +;;; +;;; {{{ name resolution +;;; + +(declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) + ipaddr-to-dotted)) +(defun ipaddr-to-dotted (ipaddr) + "Number --> string." + (declare (type (unsigned-byte 32) ipaddr)) + #+allegro (socket:ipaddr-to-dotted ipaddr) + #+(or openmcl ccl) (ccl:ipaddr-to-dotted ipaddr) + #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:ipaddr-to-dot-string ipaddr) + #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets)) + (format nil "~d.~d.~d.~d" + (logand #xff (ash ipaddr -24)) (logand #xff (ash ipaddr -16)) + (logand #xff (ash ipaddr -8)) (logand #xff ipaddr))) + +(declaim (ftype (function (string) (values (unsigned-byte 32))) + dotted-to-ipaddr)) +(defun dotted-to-ipaddr (dotted) + "String --> number." + (declare (string dotted)) + #+allegro (socket:dotted-to-ipaddr dotted) + #+(or openmcl ccl) (ccl:dotted-to-ipaddr dotted) + #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:dot-string-to-ipaddr dotted) + #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets)) + (let ((ll (string-tokens (substitute #\Space #\. dotted)))) + (+ (ash (first ll) 24) (ash (second ll) 16) + (ash (third ll) 8) (fourth ll)))) + +;#+(and sbcl (or db-sockets sb-bsd-sockets)) +;(declaim (ftype (function (vector) (values (unsigned-byte 32))) +; vector-to-ipaddr)) +#+(and sbcl (or db-sockets sb-bsd-sockets)) +(defun vector-to-ipaddr (vector) + (+ (ash (aref vector 0) 24) + (ash (aref vector 1) 16) + (ash (aref vector 2) 8) + (aref vector 3))) + +;#+(and sbcl (or db-sockets sb-bsd-sockets)) +;(declaim (ftype (function (vector) (values (unsigned-byte 32))) +; ipaddr-to-vector)) +#+(and sbcl (or db-sockets sb-bsd-sockets)) +(defun ipaddr-to-vector (ipaddr) + (vector (ldb (byte 8 24) ipaddr) + (ldb (byte 8 16) ipaddr) + (ldb (byte 8 8) ipaddr) + (ldb (byte 8 0) ipaddr))) + +(defstruct hostent + "see gethostbyname(3) for details" + (name "" :type simple-string) ; canonical name of host + (aliases nil :type list) ; alias list + (addr-list nil :type list) ; list of addresses + (addr-type 2 :type fixnum)) ; host address type + +(defun resolve-host-ipaddr (host) + "Call gethostbyname(3) or gethostbyaddr(3)." + #+allegro + (let* ((ipaddr + (etypecase host + (string + (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) + host) + (socket:dotted-to-ipaddr host) + (socket:lookup-hostname host))) + (integer host))) + (name (socket:ipaddr-to-hostname ipaddr))) + (make-hostent :name name :addr-list + (list (socket:ipaddr-to-dotted ipaddr)))) + #+(and clisp syscalls) + (let ((he (posix:resolve-host-ipaddr host))) + (make-hostent :name (posix::hostent-name he) + :aliases (posix::hostent-aliases he) + :addr-list (posix::hostent-addr-list he) + :addr-type (posix::hostent-addrtype he))) + #+(or cmu scl) + (let ((he (ext:lookup-host-entry host))) + (make-hostent :name (ext:host-entry-name he) + :aliases (ext:host-entry-aliases he) + :addr-list (mapcar #'ipaddr-to-dotted + (ext:host-entry-addr-list he)) + :addr-type (ext::host-entry-addr-type he))) + #+gcl (make-hostent :name (or (si:hostid-to-hostname host) host) + :addr-list (list (si:hostname-to-hostid host))) + #+lispworks + (multiple-value-bind (name addr aliases) + (comm:get-host-entry host :fields '(:name :address :aliases)) + (make-hostent :name name :addr-list (list (ipaddr-to-dotted addr)) + :aliases aliases)) + #+(or openmcl ccl) + (let* ((ipaddr + (etypecase host + (string + (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) + host) + (dotted-to-ipaddr host) + (ccl:lookup-hostname host))) + (integer host))) + (name (ccl:ipaddr-to-hostname ipaddr))) + (make-hostent :name name :addr-list (list (ccl:lookup-hostname ipaddr)))) + #+(and sbcl sb-bsd-sockets) + (let ((he (sb-bsd-sockets:get-host-by-name host))) + (make-hostent :name (sb-bsd-sockets:host-ent-name he) + :addr-list + (loop for ipaddr in (sb-bsd-sockets:host-ent-addresses he) + collect (format nil "~{~a~^.~}" + (loop for octect + being the elements of ipaddr + collect octect))))) + #+(and sbcl db-sockets) + (let* ((ipaddr + (etypecase host + (string + (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) + host) + (dotted-to-ipaddr host) + (let ((hostent + (sockets:get-host-by-name host))) + (when hostent + (vector-to-ipaddr + (sockets::host-ent-address hostent)))))) + (integer host))) + (name + (when ipaddr + (let ((hostent + (sockets:get-host-by-address + (ipaddr-to-vector ipaddr)))) + (when (and hostent + (sockets::host-ent-aliases hostent)) + (first (sockets::host-ent-aliases hostent))))))) + (make-hostent :name name :addr-list (list ipaddr))) + #+(and sbcl net.sbcl.sockets) + (let ((he (net.sbcl.sockets:lookup-host-entry host))) + (make-hostent :name (net.sbcl.sockets:host-entry-name he) + :aliases (net.sbcl.sockets:host-entry-aliases he) + :addr-list (mapcar #'ipaddr-to-dotted + (net.sbcl.sockets:host-entry-addr-list he)) + :addr-type (net.sbcl.sockets::host-entry-addr-type he))) + #-(or allegro (and clisp syscalls) cmu gcl lispworks openmcl ccl + (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'resolve-host-ipaddr host))) + +(defun ipaddr-closure (address) + "Resolve all addresses and names associated with the argument." + (let ((a2he (make-hash-table :test 'equalp)) + (he2a (make-hash-table :test 'equalp))) + (labels ((handle (s) + (unless (gethash s a2he) + (let ((he (resolve-host-ipaddr s))) + (setf (gethash s a2he) he) + (push s (gethash he he2a)) + (handle (hostent-name he)) + (mapc #'handle (hostent-aliases he)) + (mapc #'handle (hostent-addr-list he)))))) + (handle address)) + (values he2a a2he))) + +;;; +;;; }}}{{{ sockets +;;; + +(deftype socket () + #+abcl 'to-way-stream + #+allegro 'excl::socket-stream + #+clisp 'stream + #+(or cmu scl) 'stream ; '(or stream:socket-simple-stream sys:fd-stream) + #+gcl 'stream + #+lispworks 'comm:socket-stream + #+(or openmcl ccl) 'ccl::socket + #+(and sbcl (or db-sockets sb-bsd-sockets)) 'sb-sys:fd-stream + #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:stream-socket + #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl + (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) 'stream) + +(defun open-socket (host port &optional bin) + "Open a socket connection to HOST at PORT." + (declare (type (or integer string) host) (fixnum port) + #+(or cmu scl) (ignore bin)) + (let ((host (etypecase host + (string host) + (integer (hostent-name (resolve-host-ipaddr host)))))) + #+abcl (ext:get-socket-stream + (sys:make-socket host port) + :element-type (if bin '(unsigned-byte 8) 'character)) + #+allegro (socket:make-socket :remote-host host :remote-port port + :format (if bin :binary :text)) + #+clisp (#+lisp=cl ext:socket-connect #-lisp=cl lisp:socket-connect + port host :element-type + (if bin '(unsigned-byte 8) 'character)) + #+(or cmu scl) + (make-instance 'stream:socket-simple-stream :direction :io + :remote-host host :remote-port port) + #+gcl (si:socket port :host host) + #+lispworks (comm:open-tcp-stream host port :direction :io :element-type + (if bin 'unsigned-byte 'base-char)) + #+(or mcl ccl) (ccl:make-socket :remote-host host :remote-port port + :format (if bin :binary :text)) + #+(and sbcl db-sockets) + (let ((socket (make-instance 'sockets:inet-socket + :type :stream :protocol :tcp))) + (sockets:socket-connect socket + (sockets::host-ent-address + (sockets:get-host-by-name host)) + port) + (sockets:socket-make-stream + socket :input t :output t :buffering (if bin :none :line) + :element-type (if bin '(unsigned-byte 8) 'character))) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:make-socket + (if bin + 'net.sbcl.sockets:binary-stream-socket + 'net.sbcl.sockets:character-stream-socket) + :port port :host host) + #+(and sbcl sb-bsd-sockets) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect socket + (sb-bsd-sockets::host-ent-address + (sb-bsd-sockets:get-host-by-name host)) + port) + (sb-bsd-sockets:socket-make-stream + socket :input t :output t :buffering (if bin :none :line) + :element-type (if bin '(unsigned-byte 8) 'character))) + #-(or abcl allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'open-socket host port bin)))) + +(defun set-socket-stream-format (socket format) + "switch between binary and text output" + #+clisp (setf (stream-element-type socket) format) + #+(or acl cmu lispworks scl) + (declare (ignore socket format)) ; bivalent streams + #-(or acl clisp cmu lispworks scl) + (error 'not-implemented :proc (list 'set-socket-stream-format socket format))) + +#+(and sbcl sb-bsd-sockets) +(defun funcall-on-sock (function sock) + "Apply function (getsockname/getpeername) on socket, return host/port as two values" + (let ((sockaddr (sockint::allocate-sockaddr-in))) + (funcall function (sb-sys:fd-stream-fd sock) sockaddr sockint::size-of-sockaddr-in) + (let ((host (coerce (loop :for i :from 0 :below 4 + :collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)) + '(vector (unsigned-byte 8) 4))) + (port (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0)) + (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1)))) + (sockint::free-sockaddr-in sockaddr) + (values host port)))) + +(defun socket-host/port (sock) + "Return the remote and local host&port, as 4 values." + (declare (type socket sock)) + #+allegro (values (socket:ipaddr-to-dotted (socket:remote-host sock)) + (socket:remote-port sock) + (socket:ipaddr-to-dotted (socket:local-host sock)) + (socket:local-port sock)) + #+clisp (flet ((ip (ho) (subseq ho 0 (position #\Space ho :test #'char=)))) + (multiple-value-bind (ho1 po1) + (#+lisp=cl ext:socket-stream-peer + #-lisp=cl lisp:socket-stream-peer sock) + (multiple-value-bind (ho2 po2) + (#+lisp=cl ext:socket-stream-local + #-lisp=cl lisp:socket-stream-local sock) + (values (ip ho1) po1 + (ip ho2) po2)))) + #+(or cmu scl) + (let ((fd (sys:fd-stream-fd sock))) + (multiple-value-bind (ho1 po1) (ext:get-peer-host-and-port fd) + (multiple-value-bind (ho2 po2) (ext:get-socket-host-and-port fd) + (values (ipaddr-to-dotted ho1) po1 + (ipaddr-to-dotted ho2) po2)))) + #+gcl (let ((peer (si:getpeername sock)) + (loc (si:getsockname sock))) + (values (car peer) (caddr peer) + (car loc) (caddr loc))) + #+lispworks + (multiple-value-bind (ho1 po1) (comm:socket-stream-peer-address sock) + (multiple-value-bind (ho2 po2) (comm:socket-stream-address sock) + (values (ipaddr-to-dotted ho1) po1 + (ipaddr-to-dotted ho2) po2))) + #+(or mcl ccl) + (values (ccl:ipaddr-to-dotted (ccl:remote-host sock)) + (ccl:remote-port sock) + (ccl:ipaddr-to-dotted (ccl:local-host sock)) + (ccl:local-port sock)) + #+(and sbcl db-sockets) + (let ((sock (sb-sys:fd-stream-fd sock))) + (multiple-value-bind (remote remote-port) (sockets:socket-peername sock) + (multiple-value-bind (local local-port) (sockets:socket-name sock) + (values (ipaddr-to-dotted (vector-to-ipaddr remote)) + remote-port + (ipaddr-to-dotted (vector-to-ipaddr local)) + local-port)))) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:socket-host-port sock) + #+(and sbcl sb-bsd-sockets) + (multiple-value-bind (remote remote-port) + (funcall-on-sock #'sockint::getpeername sock) + (multiple-value-bind (local local-port) + (funcall-on-sock #'sockint::getsockname sock) + (values (ipaddr-to-dotted (vector-to-ipaddr remote)) + remote-port + (ipaddr-to-dotted (vector-to-ipaddr local)) + local-port))) + #-(or allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-host/port sock))) + +(defun socket-string (sock) + "Print the socket local&peer host&port to a string." + (declare (type socket sock)) + (with-output-to-string (stream) + (print-unreadable-object (sock stream :type t :identity t) + (multiple-value-bind (ho1 po1 ho2 po2) (socket-host/port sock) + (format stream "[local: ~a:~d] [peer: ~s:~d]" ho2 po2 ho1 po1))))) + +;;; +;;; }}}{{{ socket-servers +;;; + +#+lispworks (defstruct socket-server proc mbox port) +#-lispworks +(deftype socket-server () + #+abcl 'ext:javaobject + #+allegro 'acl-socket::socket-stream-internet-passive + #+(and clisp lisp=cl) 'ext:socket-server + #+(and clisp (not lisp=cl)) 'lisp:socket-server + #+(or cmu scl) 'integer + #+gcl 'si:socket-stream + #+(or mcl ccl) 'ccl::listener-socket + #+(and sbcl db-sockets) 'sb-sys:fd-stream + #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:passive-socket + #+(and sbcl sb-bsd-sockets) 'sb-bsd-sockets:inet-socket + #-(or abcl allegro clisp cmu gcl mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets)) scl) t) + +(defun open-socket-server (&optional port) + "Open a `generic' socket server." + (declare (type (or null integer #-sbcl socket) port)) + #+abcl (ext:make-server-socket port) + #+allegro (socket:make-socket :connect :passive :local-port + (when (integerp port) port)) + #+clisp (#+lisp=cl ext:socket-server #-lisp=cl lisp:socket-server port) + #+(or cmu scl) (ext:create-inet-listener (or port 0) :stream :reuse-address t) + #+gcl (si:make-socket-pair port) ; FIXME + #+lispworks (let ((mbox (mp:make-mailbox :size 1))) + (make-socket-server + :mbox mbox :port port + :proc (comm:start-up-server + :function (lambda (sock) (mp:mailbox-send mbox sock)) + :service port))) + #+(or mcl ccl) + (ccl:make-socket :connect :passive + :type :stream + :reuse-address t + :local-port (or port 0)) + #+(and sbcl db-sockets) + (let ((socket (make-instance 'sockets:inet-socket + :type :stream :protocol :tcp))) + (sockets:socket-bind socket (vector 0 0 0 0) (or port 0))) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:make-socket 'net.sbcl.sockets:passive-socket :port port) + #+(and sbcl sb-bsd-sockets) + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address sock) t) + (sb-bsd-sockets:socket-bind sock (vector 0 0 0 0) (or port 0)) + (sb-bsd-sockets:socket-listen sock 15) + sock) + #-(or abcl allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'open-socket-server port))) + +(defun socket-accept (serv &key bin wait) + "Accept a connection on a socket server (passive socket). +Keyword arguments are: + BIN - create a binary stream; + WAIT - wait for the connection this many seconds + (the default is NIL - wait forever). +Returns a socket stream or NIL." + (declare (type socket-server serv) + #+(or (and allegro (version>= 6)) openmcl ccl) + (ignore bin)) + #+abcl (ext:get-socket-stream + (ext:socket-accept serv) + :element-type (if bin '(unsigned-byte 8) 'character)) + #+allegro (let* ((fmt (if bin :binary :text)) + #+allegro-v5.0 + (excl:*default-external-format* fmt) + (sock (if wait + (if (plusp wait) + (mp:with-timeout (wait) + (socket:accept-connection serv :wait t)) + (socket:accept-connection serv :wait nil)) + (socket:accept-connection serv :wait t)))) + (when sock + ;; From: John Foderaro + ;; Date: Sun, 12 Nov 2000 16:58:28 -0800 + ;; in ACL6 and later, all sockets are bivalent (both + ;; text and binary) and thus there's no need to convert + ;; between the element types. + #+allegro-v5.0 + (unless (eq (socket:socket-format sock) fmt) + (warn "~s: ACL5 cannot modify socket format" + 'socket-accept)) + #+allegro-v4.3 + (socket:set-socket-format sock fmt) + sock)) + #+clisp (multiple-value-bind (sec usec) (floor (or wait 0)) + (when (#+lisp=cl ext:socket-wait #-lisp=cl lisp:socket-wait + serv (and wait sec) (round usec 1d-6)) + (#+lisp=cl ext:socket-accept #-lisp=cl lisp:socket-accept + serv :element-type + (if bin '(unsigned-byte 8) 'character)))) + #+(or cmu scl) + (when (sys:wait-until-fd-usable serv :input wait) + (sys:make-fd-stream (ext:accept-tcp-connection serv) + :buffering (if bin :full :line) + :input t :output t :element-type + (if bin '(unsigned-byte 8) 'character))) + #+gcl (si:accept-socket-connection serv bin wait) ; FIXME + #+lispworks (make-instance + 'comm:socket-stream :direction :io + :socket (mp:mailbox-read (socket-server-mbox serv)) + :element-type (if bin 'unsigned-byte 'base-char)) + ;; For ccl, as wait is a boolean, the time to wait is ignored. + #+(or mcl ccl) (ccl:accept-connection serv :wait (not wait)) + #+(and sbcl db-sockets) + (let ((new-connection (sockets:socket-accept serv))) + ;; who needs WAIT and BIN anyway :-S + new-connection) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:accept-connection + serv + (if bin + 'net.sbcl.sockets:binary-stream-socket + 'net.sbcl.sockets:character-stream-socket) + :wait wait) + #+(and sbcl sb-bsd-sockets) + (progn + (setf (sb-bsd-sockets:non-blocking-mode serv) wait) + (let ((s (sb-bsd-sockets:socket-accept serv))) + (if s + (sb-bsd-sockets:socket-make-stream + s :input t :output t + :element-type (if bin '(unsigned-byte 8) 'character) + :buffering (if bin :full :line)) + (sleep wait)))) + #-(or abcl allegro clisp cmu gcl lispworks mcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-accept serv bin))) + +(defun socket-server-close (server) + "Close the server." + (declare (type socket-server server)) + #+abcl (ext:server-socket-close server) + #+allegro (close server) + #+clisp (#+lisp=cl ext:socket-server-close + #-lisp=cl lisp:socket-server-close server) + #+(or cmu scl) (unix:unix-close server) + #+gcl (close server) + #+lispworks (mp:process-kill (socket-server-proc server)) + #+(or openmcl ccl) (close server) + #+(and sbcl db-sockets) (sockets:socket-close server) + #+(and sbcl net.sbcl.sockets) (close server) + #+(and sbcl sb-bsd-sockets) (sb-bsd-sockets:socket-close server) + #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-server-close server))) + +(defun socket-server-host/port (server) + "Return the local host&port on which the server is running, as 2 values." + (declare (type socket-server server)) + #+allegro (values (socket:ipaddr-to-dotted (socket:local-host server)) + (socket:local-port server)) + #+(and clisp lisp=cl) (values (ext:socket-server-host server) + (ext:socket-server-port server)) + #+(and clisp (not lisp=cl)) (values (lisp:socket-server-host server) + (lisp:socket-server-port server)) + #+(or cmu scl) + (values (ipaddr-to-dotted (car (ext:host-entry-addr-list + (ext:lookup-host-entry "localhost")))) + (nth-value 1 (ext:get-socket-host-and-port server))) + #+gcl (let ((sock (si:getsockname server))) + (values (car sock) (caddr sock))) + #+lispworks (values (ipaddr-to-dotted (comm:get-host-entry + "localhost" :fields '(:address))) + (socket-server-port server)) + #+(or openmcl ccl) + (values (ccl:ipaddr-to-dotted (ccl:local-host server)) + (ccl:local-port server)) + #+(and sbcl db-sockets) + (multiple-value-bind (addr port) (sockets:socket-name server) + (values (vector-to-ipaddr addr) port)) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:passive-socket-host-port server) + #+(and sbcl sb-bsd-sockets) + (multiple-value-bind (addr port) (sb-bsd-sockets:socket-name server) + (values (ipaddr-to-dotted (vector-to-ipaddr addr)) port)) + #-(or allegro clisp cmu gcl lispworks openmcl ccl + (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) + (error 'not-implemented :proc (list 'socket-server-host/port server))) + +;;; +;;; }}}{{{ for CLX +;;; + +(defun wait-for-stream (stream &optional timeout) + "Sleep until there is input on the STREAM, or for TIMEOUT seconds, +whichever comes first. If there was a timeout, return NIL." + #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) + (#+lisp=cl ext:socket-status #-lisp=cl lisp:socket-status + stream (and timeout sec) (round usec 1d-6))) + #+(or cmu scl) + (#+mp mp:process-wait-until-fd-usable #-mp sys:wait-until-fd-usable + (system:fd-stream-fd stream) :input timeout) + #+(or openmcl ccl) + (ccl:make-socket :type :stream + :address-family :file + :connect :active + :format :text ;;(if bin :binary :text) + :remote-filename #P"");;path) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:wait-for-input-data stream timeout) + #+(and sbcl db-sockets) + (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) + #-(or clisp cmu (and sbcl (or net.sbcl.sockets db-sockets)) scl) + (error 'not-implemented :proc (list 'wait-for-stream stream timeout))) + +(defun open-unix-socket (path &key (kind :stream) bin) + "Opens a unix socket. Path is the location. +Kind can be :stream or :datagram." + (declare (simple-string path) #-(or cmu sbcl) (ignore kind)) + #+allegro (socket:make-socket :type :stream + :address-family :file + :connect :active + :remote-filename path) + #+cmu (sys:make-fd-stream (ext:connect-to-unix-socket path kind) + :input t :output t :element-type + (if bin '(unsigned-byte 8) 'character)) + #+(and sbcl net.sbcl.sockets) + (net.sbcl.sockets:make-socket 'net.sbcl.sockets:unix-stream-socket + :buffering :full :path path :type kind) + #+(and sbcl db-sockets) + (let ((socket (make-instance 'sockets:unix-socket :type :stream))) + (sockets:socket-connect socket path) + (sockets:socket-make-stream socket :input t :output t + :buffering :none + :element-type '(unsigned-byte 8))) + #-(or allegro cmu (and sbcl (or net.sbcl.sockets db-sockets))) + (open path :element-type (if bin '(unsigned-byte 8) 'character) + :direction :io)) + +;;; +;;; }}}{{{ conditions +;;; + +(defun report-network-condition (cc out) + (declare (stream out)) + (format out "[~s] ~s:~d~@[ ~?~]" (net-proc cc) (net-host cc) + (net-port cc) (net-mesg cc) (net-args cc))) + +(define-condition network (error) + ((proc :type symbol :reader net-proc :initarg :proc :initform nil) + (host :type simple-string :reader net-host :initarg :host :initform "") + (port :type (unsigned-byte 16) :reader net-port :initarg :port :initform 0) + (mesg :type (or null simple-string) :reader net-mesg + :initarg :mesg :initform nil) + (args :type list :reader net-args :initarg :args :initform nil)) + (:report report-network-condition)) + +(define-condition timeout (network) + ((time :type (real 0) :reader timeout-time :initarg :time :initform 0)) + (:report (lambda (cc out) + (declare (stream out)) + (report-network-condition cc out) + (when (plusp (timeout-time cc)) + (format out " [timeout ~a sec]" (timeout-time cc)))))) + +(define-condition login (network) ()) +(define-condition net-path (network) ()) + +;;; +;;; }}}{{{ `socket-service-port' +;;; + +(defstruct servent + "see getservbyname(3) for details" + (name "" :type simple-string) ; official name of service + (aliases nil :type list) ; alias list + (port -1 :type fixnum) ; port service resides at + (proto :tcp :type symbol)) ; protocol to use + +(defun socket-service-port (&optional service (protocol "tcp")) + "Return the SERVENT structure corresponding to the SERVICE. +When SERVICE is NIL, return the list of all services." + (with-open-file (fl #+unix "/etc/services" #+(or win32 mswindows) + (concatenate 'string (getenv "windir") + "/system32/drivers/etc/services") + :direction :input) + (loop :with name :and aliases :and port :and prot :and tokens + :for st = (read-line fl nil nil) + :until (null st) + :unless (or (zerop (length st)) (char= #\# (schar st 0))) + :do (setq tokens (string-tokens + (nsubstitute + #\Space #\/ (subseq st 0 (position #\# st)))) + name (string-downcase (string (first tokens))) + aliases (mapcar (compose string-downcase string) + (cdddr tokens)) + port (second tokens) + prot (third tokens)) :and + :if service + :when (and (string-equal protocol prot) + (or (string-equal service name) + (member service aliases :test #'string-equal))) + :return (make-servent :name name :aliases aliases :port port + :proto prot) + :end + :else :collect (make-servent :name name :aliases aliases :port port + :proto prot) + :end + :end + :finally (when service + (error "~s: service ~s is not found for protocol ~s" + 'socket-service-port service protocol))))) + +;;; }}} + +(provide :port-net) +;;; file net.lisp ends here Added: clfswm/contrib/server/server.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/server.lisp Thu Aug 12 17:30:52 2010 @@ -0,0 +1,257 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: Utility +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2005 Philippe Brochard +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; -------------------------------------------------------------------------- +;;; Server protocole: +;;; Server -> Client: orig_key=a generated key crypted with *key* +;;; Client : build its new_key with orig_key+*key* +;;; Client -> Server: new_key+(md5 new_key) crypted with new_key +;;; Server -> Client: check if the keys match and then authenticate the client. +;;; +;;; -------------------------------------------------------------------------- + + +(format t "Loading the clfswm server code... ") + +(pushnew (truename (concatenate 'string *contrib-dir* "contrib/" "server/")) asdf:*central-registry*) + +(dbg asdf:*central-registry*) + +(asdf:oos 'asdf:load-op :util-server) + +(in-package :clfswm) + +(use-package :crypt) + +(defstruct server-socket stream auth form key) + +(defparameter *server-socket* nil) +(defparameter *server-port* 33333) +(defparameter *server-allowed-host* '("127.0.0.1")) + +(defparameter *server-connection* nil) + +(defparameter *server-commands* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]")) + + + + + +(defun send-to-client (sock show-prompt-p &rest msg) + (dolist (m (if (consp (car msg)) (car msg) msg)) + (format (server-socket-stream sock) "~A~%" (crypt m (server-socket-key sock))) + (force-output (server-socket-stream sock))) + (when show-prompt-p + (server-show-prompt sock))) + + +(defun server-show-prompt (sock) + (send-to-client sock nil (format nil "~A> " (package-name *package*)))) + + +(defun read-from-client (sock) + (decrypt (read-line (server-socket-stream sock) nil nil) (server-socket-key sock))) + + + +(defun server-remove-connection (sock) + (send-to-client sock nil "Connection closed by server") + (multiple-value-bind (local-host local-port remote-host remote-port) + (port:socket-host/port (server-socket-stream sock)) + (declare (ignore local-host local-port)) + (format t "~&Connection from ~A:~A closed.~%" remote-host remote-port)) + (close (server-socket-stream sock)) + (setf *server-connection* (remove sock *server-connection*))) + +(defun server-show-info (sock) + (send-to-client sock t (format nil "~A" *server-connection*))) + + +(defun server-clear-connection () + (dolist (sock *server-connection*) + (handler-case + (send-to-client sock t "Server clear connection in progress.") + (error () + (server-remove-connection sock))))) + + +(defun server-show-help (sock) + (send-to-client sock t (format nil "Availables commandes: ~{~S~^, ~}" *server-commands*))) + + +(defun server-ls (sock line ls-word var-p fun-p &optional show-doc) + (let* ((pattern (string-trim '(#\space #\tab) (subseq (string-trim '(#\space #\tab) line) (length ls-word)))) + (all-search (string= pattern ""))) + (with-all-internal-symbols (symbol :clfswm) + (when (or all-search (symbol-search pattern symbol)) + (cond ((and var-p (boundp symbol)) + (send-to-client sock nil (format nil "~A (variable) ~A" symbol + (if show-doc + (format nil "~& ~A~& => ~A" + (documentation symbol 'variable) + (symbol-value symbol)) + "")))) + ((and fun-p (fboundp symbol)) + (send-to-client sock nil (format nil "~A (function) ~A" symbol + (if show-doc + (documentation symbol 'function) + ""))))))) + (send-to-client sock t "Done."))) + + + +(defun server-is-allowed-host (stream) + (multiple-value-bind (local-host local-port remote-host remote-port) + (port:socket-host/port stream) + (declare (ignore local-host local-port)) + (and (member remote-host *server-allowed-host* :test #'string-equal) + (equal remote-port *server-port*)))) + + +(defun server-handle-new-connection () + (handler-case + (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait 0.01d0)))) + (when stream + (if (server-is-allowed-host stream) + (multiple-value-bind (local-host local-port remote-host remote-port) + (port:socket-host/port stream) + (declare (ignore local-host local-port)) + (format t "~&New connection from ~A:~A " remote-host remote-port) + (let ((new-sock (make-server-socket :stream stream :auth nil :form "" :key *key*)) + (key (generate-key))) + (push new-sock *server-connection*) + (send-to-client new-sock nil key) + (setf (server-socket-key new-sock) (concatenate 'string key *key*)))) + (close stream)))) + (error (c) + (format t "Connection rejected: ~A~%" c) + (force-output)))) + + +(defun server-line-is (line &rest strings) + (dolist (str strings) + (when (string-equal line str) + (return-from server-line-is t))) + nil) + + +(defun server-complet-from (sock) + (ignore-errors + (when (listen (server-socket-stream sock)) + (let ((line (read-from-client sock))) + (cond ((server-line-is line "help") (server-show-help sock)) + ((server-line-is line "bye" "close" "quit") (server-remove-connection sock)) + ((server-line-is line "info") (server-show-info sock)) + ((server-line-is line "clear") (server-clear-connection)) + ((first-position "lsdv" line) (server-ls sock line "lsdv" t nil t)) + ((first-position "lsdf" line) (server-ls sock line "lsdf" nil t t)) + ((first-position "lsd" line) (server-ls sock line "lsd" t t t)) + ((first-position "lsv" line) (server-ls sock line "lsv" t nil nil)) + ((first-position "lsf" line) (server-ls sock line "lsf" nil t nil)) + ((first-position "ls" line) (server-ls sock line "ls" t t nil)) + (t (setf (server-socket-form sock) (format nil "~A~A~%" (server-socket-form sock) line)))))))) + + + + + +(defun server-eval-form (sock) + (let* ((result nil) + (printed-result + (with-output-to-string (*standard-output*) + (setf result (handler-case + (loop for i in (multiple-value-list + (eval (read-from-string (server-socket-form sock)))) + collect (format nil "~S" i)) + (error (condition) + (format nil "~A" condition))))))) + (send-to-client sock nil (ensure-list printed-result)) + (send-to-client sock t (ensure-list result)) + (setf (server-socket-form sock) ""))) + + +(defun server-handle-form (sock) + (server-complet-from sock) + (if (server-socket-key sock) + (when (ignore-errors (read-from-string (server-socket-form sock))) + (server-eval-form sock)) + (server-show-prompt sock))) + +(defun server-handle-auth (sock) + (loop for line = (read-from-client sock) + while line + do + (if (string= line (format nil "~A~A" (server-socket-key sock) + (md5:md5 (server-socket-key sock)))) + (progn + (setf (server-socket-auth sock) t) + (setf (server-socket-form sock) (format nil "~S" "You are now authenticated!")) + (server-handle-form sock) + (format t "Connection accepted~%") + (return-from server-handle-auth nil)) + (progn + (format t "Connection closed~%") + (close (server-socket-stream sock)))))) + + +(defun server-handle-connection (sock) + (handler-case + (when (listen (server-socket-stream sock)) + (if (server-socket-auth sock) + (server-handle-form sock) + (server-handle-auth sock))) + (error (c) + (format t "*** Error: ~A~%" c) (force-output) + (close (server-socket-stream sock)) + (setf *server-connection* (remove sock *server-connection*))))) + +(defun handle-server () + (server-handle-new-connection) + (dolist (sock *server-connection*) + (server-handle-connection sock))) + + + +(defun start-server (&optional port) + (save-new-key) + (when port + (setf *server-port* port)) + (setf *server-socket* (port:open-socket-server *server-port*)) + (add-hook *loop-hook* 'handle-server) + (format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%" + *server-port* *server-allowed-host*)) + + + + +(format t "done. + +You can now start a clfswm server with the command (start-server &optional port). +Only [~{~A~^, ~}] ~A allowed to login on the server~%" + *server-allowed-host* + (if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1)) + "is" "are")) + + + + Added: clfswm/contrib/server/test.sh ============================================================================== --- (empty file) +++ clfswm/contrib/server/test.sh Thu Aug 12 17:30:52 2010 @@ -0,0 +1,7 @@ +#! /bin/sh + +clisp load.lisp "(print 'toto) (print (+ 2 2))" "(leave-frame)" " quit " +#cmucl -load load.lisp "(print 'toto)" "(print (+ 2 2))" "(leave-frame)" "quit" +#sbcl --load load.lisp "(print 'toto)" "(print (+ 2 2))" "(leave-frame)" "quit" +#ccl --load load.lisp -- "(print 'toto)" "(print (+ 2 2))" "(leave-frame)" "quit" +#/tmp/local/bin/clfswm-client "(print 'toto)" "(print 'toto) (print (+ 2 2))" "(leave-frame)" "quit" Added: clfswm/contrib/server/test2.sh ============================================================================== --- (empty file) +++ clfswm/contrib/server/test2.sh Thu Aug 12 17:30:52 2010 @@ -0,0 +1,18 @@ +#! /bin/sh + +EXEC_CMD='(leave-frame) +(select-previous-level) +(let ((frame (create-frame \:name \"Test root\" \:x 0.05 \:y 0.05))) + (add-frame frame *current-child*) + (add-frame (create-frame \:name \"Test 1\" \:x 0.3 \:y 0 \:w 0.7 \:h 1) frame) + (add-frame (create-frame \:name \"Test 2\" \:x 0 \:y 0 \:w 0.3 \:h 1) frame) + (setf *current-child* (first (frame-child frame)))) +(show-all-children *current-root*) +quit' + +clisp load.lisp "$EXEC_CMD" +#cmucl -load load.lisp "$EXEC_CMD" +#sbcl --load load.lisp "$EXEC_CMD" +#ccl --load load.lisp -- "$EXEC_CMD" +#/tmp/local/bin/clfswm-client "$EXEC_CMD" + Added: clfswm/contrib/server/util-server.asd ============================================================================== --- (empty file) +++ clfswm/contrib/server/util-server.asd Thu Aug 12 17:30:52 2010 @@ -0,0 +1,23 @@ +;;;; -*- Mode: Lisp -*- +;;;; ASDF System Definition +;;; + +(in-package #:asdf) + +(defsystem util-server + :description "" + :licence "GNU Lesser General Public License (LGPL)" + :components ((:file "md5") + (:file "net") + (:file "crypt") + (:file "key" + :depends-on ("crypt")))) + + + + + + + + + From pbrochard at common-lisp.net Thu Aug 12 21:32:05 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 12 Aug 2010 17:32:05 -0400 Subject: [clfswm-cvs] r288 - clfswm/contrib/server Message-ID: Author: pbrochard Date: Thu Aug 12 17:32:05 2010 New Revision: 288 Log: contrib/server cleaning Removed: clfswm/contrib/server/clfswm-client.fas clfswm/contrib/server/clfswm-client.lib clfswm/contrib/server/crypt.fas clfswm/contrib/server/crypt.lib clfswm/contrib/server/key.fas clfswm/contrib/server/key.lib clfswm/contrib/server/md5.fas clfswm/contrib/server/md5.lib clfswm/contrib/server/net.fas clfswm/contrib/server/net.lib From pbrochard at common-lisp.net Mon Aug 16 21:23:20 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 16 Aug 2010 17:23:20 -0400 Subject: [clfswm-cvs] r289 - in clfswm: . src Message-ID: Author: pbrochard Date: Mon Aug 16 17:23:20 2010 New Revision: 289 Log: src/*.lisp: Replace the case to handle event with a more (tricky) lispy method which bind a function to each keywords associated to graphics events. Remove event handler hooks as they're not needed anymore (To replace them: use closure and define-handler). Modified: clfswm/ChangeLog clfswm/TODO clfswm/clfswm.asd clfswm/load.lisp clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-generic-mode.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-query.lisp clfswm/src/clfswm-second-mode.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/package.lisp clfswm/src/tools.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Aug 16 17:23:20 2010 @@ -1,3 +1,15 @@ +2010-08-16 Philippe Brochard + + * src/package.lisp: Remove event handler hooks as they're not + needed anymore (To replace them: use closure and define-handler). + + * src/xlib-util.lisp (move-window, resize-window) + (wait-mouse-button-release): Use a generic mode. + + * src/*.lisp: Replace the case to handle event with a more (tricky) + lispy method which bind a function to each keywords associated + to graphics events. + 2010-07-23 Philippe Brochard * src/clfswm-util.lisp (delete-current-child): Invert bindings and Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Mon Aug 16 17:23:20 2010 @@ -7,16 +7,7 @@ =============== Should handle these soon. -- Remote access to the clfswm REPL [Philippe] - this can be done with net.lisp or via xprop (ie the Stumpwm way). - Protocol: - - start-server => create a new file /tmp/clfswm-server-port with right (rw-------) - and place a key which change on each connection. - - client must read this file and send the key before using the command line. - - server change its key when the connection is done. - - add a minimal cript in the protocol (for example a rotN) with N coded in the key. - - +Nothing here :) MAYBE ===== @@ -37,6 +28,6 @@ * up * down -- Undo/redo (any idea to implement this is welcome) +- Undo/redo Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Mon Aug 16 17:23:20 2010 @@ -31,10 +31,10 @@ :depends-on ("package" "config" "xlib-util" "keysyms")) (:file "clfswm-autodoc" :depends-on ("package" "clfswm-keys" "my-html" "tools" "config")) - (:file "clfswm-generic-mode" - :depends-on ("package" "tools" "xlib-util")) (:file "clfswm-internal" :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config")) + (:file "clfswm-generic-mode" + :depends-on ("package" "tools" "xlib-util" "clfswm-internal")) (:file "clfswm-circulate-mode" :depends-on ("xlib-util" "clfswm-keys" "clfswm-generic-mode" "clfswm-internal" "netwm-util" "tools" "config")) Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Mon Aug 16 17:23:20 2010 @@ -49,6 +49,9 @@ (push *base-dir* asdf:*central-registry*) +;;;; Uncomment the line above if you want to follow the +;;;; handle event mecanism. +;;(pushnew :event-debug *features*) (asdf:oos 'asdf:load-op :clfswm) @@ -61,8 +64,8 @@ ;;(produce-all-docs) -;;; For debuging: start Xnest or Zephyr and -;;; add the lines above in a dot-clfswmrc-debug file +;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest +;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file ;;; mod-2 is the numlock key on some keyboards. ;;(setf *default-modifiers* '(:mod-2)) ;; Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Mon Aug 16 17:23:20 2010 @@ -154,21 +154,6 @@ (add-hook *binding-hook* 'set-default-second-keys) -;; For a French azery keyboard: -;;(undefine-second-multi-keys (#\1 :mod-1) (#\2 :mod-1) (#\3 :mod-1) -;; (#\4 :mod-1) (#\5 :mod-1) (#\6 :mod-1) -;; (#\7 :mod-1) (#\8 :mod-1) (#\9 :mod-1) (#\0 :mod-1)) -;;(define-second-key ("ampersand" :mod-1) 'bind-or-jump 1) -;;(define-second-key ("eacute" :mod-1) 'bind-or-jump 2) -;;(define-second-key ("quotedbl" :mod-1) 'bind-or-jump 3) -;;(define-second-key ("quoteright" :mod-1) 'bind-or-jump 4) -;;(define-second-key ("parenleft" :mod-1) 'bind-or-jump 5) -;;(define-second-key ("minus" :mod-1) 'bind-or-jump 6) -;;(define-second-key ("egrave" :mod-1) 'bind-or-jump 7) -;;(define-second-key ("underscore" :mod-1) 'bind-or-jump 8) -;;(define-second-key ("ccedilla" :mod-1) 'bind-or-jump 9) -;;(define-second-key ("agrave" :mod-1) 'bind-or-jump 10) - ;;; Mouse action Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Mon Aug 16 17:23:20 2010 @@ -83,22 +83,6 @@ (add-hook *binding-hook* 'set-default-main-keys) -;; For an azery keyboard: -;;(undefine-main-multi-keys (#\1 :mod-1) (#\2 :mod-1) (#\3 :mod-1) -;; (#\4 :mod-1) (#\5 :mod-1) (#\6 :mod-1) -;; (#\7 :mod-1) (#\8 :mod-1) (#\9 :mod-1) (#\0 :mod-1)) -;;(define-main-key ("ampersand" :mod-1) 'bind-or-jump 1) -;;(define-main-key ("eacute" :mod-1) 'bind-or-jump 2) -;;(define-main-key ("quotedbl" :mod-1) 'bind-or-jump 3) -;;(define-main-key ("quoteright" :mod-1) 'bind-or-jump 4) -;;(define-main-key ("parenleft" :mod-1) 'bind-or-jump 5) -;;(define-main-key ("minus" :mod-1) 'bind-or-jump 6) -;;(define-main-key ("egrave" :mod-1) 'bind-or-jump 7) -;;(define-main-key ("underscore" :mod-1) 'bind-or-jump 8) -;;(define-main-key ("ccedilla" :mod-1) 'bind-or-jump 9) -;;(define-main-key ("agrave" :mod-1) 'bind-or-jump 10) - - Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Mon Aug 16 17:23:20 2010 @@ -190,8 +190,7 @@ (when leave (leave-circulate-mode)))) -(defun circulate-handle-key-press (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) +(define-handler circulate-mode :key-press (code state) (unless (funcall-key-from-code *circulate-keys* code state) (setf *circulate-hit* 0 *circulate-orig* nil @@ -199,8 +198,7 @@ (funcall-key-from-code *main-keys* code state))) -(defun circulate-handle-key-release (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) +(define-handler circulate-mode :key-release (code state) (funcall-key-from-code *circulate-keys-release* code state)) @@ -237,11 +235,10 @@ (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) - (generic-mode 'exit-circulate-loop + (generic-mode 'circulate-mode 'exit-circulate-loop :loop-function #'circulate-loop-function :leave-function #'circulate-leave-function - :key-press-hook #'circulate-handle-key-press - :key-release-hook #'circulate-handle-key-release) + :original-mode '(main-mode)) (circulate-leave-function) (unless grab-keyboard-p (xungrab-keyboard) @@ -280,133 +277,3 @@ (setf *circulate-orig* (frame-child *circulate-parent*))) (circulate-mode :brother-direction -1)) - -;;;; New circulate mode - work in progress -;;(let ((modifier nil) -;; (reverse-modifiers nil)) -;; (defun define-circulate-modifier (keysym) -;; (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym))))) -;; (defun define-circulate-reverse-modifier (keysym-list) -;; (setf reverse-modifiers keysym-list)) -;; (defun select-next-* (orig direction set-fun) -;; (let ((done nil) -;; (hit 0)) -;; (labels ((is-reverse-modifier (code state) -;; (member (keysym->keysym-name (keycode->keysym code (state->modifiers state))) -;; reverse-modifiers :test #'string=)) -;; (reorder () -;; (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) -;; (funcall set-fun (nconc (list elem) (remove elem orig))))) -;; (handle-key-press (&rest event-slots &key code state &allow-other-keys) -;; (declare (ignore event-slots)) -;; ;;(dbg 'press root code state) -;; ;;(dbg (first reverse-modifiers) (state->modifiers state)) -;; (if (is-reverse-modifier code state) -;; (setf direction -1) -;; (reorder))) -;; (handle-key-release (&rest event-slots &key code state &allow-other-keys) -;; (declare (ignore event-slots)) -;; ;;(dbg 'release root code state) -;; (when (is-reverse-modifier code state) -;; (setf direction 1)) -;; (when (member code modifier) -;; (setf done t))) -;; (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys) -;; (declare (ignore display)) -;; (with-xlib-protect -;; (case event-key -;; (:key-press (apply #'handle-key-press event-slots)) -;; (:key-release (apply #'handle-key-release event-slots)))) -;; t)) -;; (ungrab-main-keys) -;; (xgrab-keyboard *root*) -;; (reorder) -;; (loop until done do -;; (with-xlib-protect -;; (xlib:display-finish-output *display*) -;; (xlib:process-event *display* :handler #'handle-select-next-child-event))) -;; (xungrab-keyboard) -;; (grab-main-keys))))) -;; -;;(defun set-select-next-child (new) -;; (setf (frame-child *current-child*) new) -;; (show-all-children)) -;; -;;(defun select-next-child () -;; "Select the next child" -;; (select-next-* (frame-child *current-child*) 1 #'set-select-next-child)) -;; -;;(defun select-previous-child () -;; "Select the previous child" -;; (select-next-* (frame-child *current-child*) -1 #'set-select-next-child)) -;; -;;(let ((parent nil)) -;; (defun set-select-next-brother (new) -;; (let ((frame-is-root? (and (equal *current-root* *current-child*) -;; (not (equal *current-root* *root-frame*))))) -;; (if frame-is-root? -;; (hide-all *current-root*) -;; (select-current-frame nil)) -;; (setf (frame-child parent) new -;; *current-child* (frame-selected-child parent)) -;; (when frame-is-root? -;; (setf *current-root* *current-child*)) -;; (show-all-children *current-root*))) -;; -;; (defun select-next-brother () -;; "Select the next brother frame" -;; (setf parent (find-parent-frame *current-child*)) -;; (when (frame-p parent) -;; (select-next-* (frame-child parent) 1 #'set-select-next-brother))) -;; -;; (defun select-previous-brother () -;; "Select the previous brother frame" -;; (setf parent (find-parent-frame *current-child*)) -;; (when (frame-p parent) -;; (select-next-* (frame-child parent) -1 #'set-select-next-brother)))) - - -;;;;; This is only transitional -;;(defun select-next/previous-child (fun-rotate) -;; "Select the next/previous child" -;; (when (frame-p *current-child*) -;; (unselect-all-frames) -;; (with-slots (child) *current-child* -;; (setf child (funcall fun-rotate child))) -;; (show-all-children))) -;; -;; -;;(defun select-next-child () -;; "Select the next child" -;; (select-next/previous-child #'rotate-list)) -;; -;;(defun select-previous-child () -;; "Select the previous child" -;; (select-next/previous-child #'anti-rotate-list)) -;; -;; -;;(defun select-next/previous-brother (fun-rotate) -;; "Select the next/previous brother frame" -;; (let ((frame-is-root? (and (equal *current-root* *current-child*) -;; (not (equal *current-root* *root-frame*))))) -;; (if frame-is-root? -;; (hide-all *current-root*) -;; (select-current-frame nil)) -;; (let ((parent (find-parent-frame *current-child*))) -;; (when (frame-p parent) -;; (with-slots (child) parent -;; (setf child (funcall fun-rotate child)) -;; (setf *current-child* (frame-selected-child parent))))) -;; (when frame-is-root? -;; (setf *current-root* *current-child*)) -;; (show-all-children *current-root*))) -;; -;; -;;(defun select-next-brother () -;; "Select the next brother frame" -;; (select-next/previous-brother #'anti-rotate-list)) -;; -;;(defun select-previous-brother () -;; "Select the previous brother frame" -;; (select-next/previous-brother #'rotate-list)) -;;;;; end transitional part Modified: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- clfswm/src/clfswm-generic-mode.lisp (original) +++ clfswm/src/clfswm-generic-mode.lisp Mon Aug 16 17:23:20 2010 @@ -26,46 +26,15 @@ (in-package :clfswm) -(defun generic-mode (exit-tag &key enter-function loop-function leave-function - (loop-hook *loop-hook*) - (button-press-hook *button-press-hook*) - (button-release-hook *button-release-hook*) - (motion-notify-hook *motion-notify-hook*) - (key-press-hook *key-press-hook*) - (key-release-hook *key-release-hook*) - (configure-request-hook *configure-request-hook*) - (configure-notify-hook *configure-notify-hook*) - (map-request-hook *map-request-hook*) - (unmap-notify-hook *unmap-notify-hook*) - (destroy-notify-hook *destroy-notify-hook*) - (mapping-notify-hook *mapping-notify-hook*) - (property-notify-hook *property-notify-hook*) - (create-notify-hook *create-notify-hook*) - (enter-notify-hook *enter-notify-hook*) - (exposure-hook *exposure-hook*)) +(defun generic-mode (mode exit-tag &key enter-function loop-function leave-function + (loop-hook *loop-hook*) original-mode) "Enter in a generic mode" - (labels ((handler-function (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - ;; (dbg event-key) - (with-xlib-protect - (case event-key - (:button-press (call-hook button-press-hook event-slots)) - (:button-release (call-hook button-release-hook event-slots)) - (:motion-notify (call-hook motion-notify-hook event-slots)) - (:key-press (call-hook key-press-hook event-slots)) - (:key-release (call-hook key-release-hook event-slots)) - (:configure-request (call-hook configure-request-hook event-slots)) - (:configure-notify (call-hook configure-notify-hook event-slots)) - (:map-request (call-hook map-request-hook event-slots)) - (:unmap-notify (call-hook unmap-notify-hook event-slots)) - (:destroy-notify (call-hook destroy-notify-hook event-slots)) - (:mapping-notify (call-hook mapping-notify-hook event-slots)) - (:property-notify (call-hook property-notify-hook event-slots)) - (:create-notify (call-hook create-notify-hook event-slots)) - (:enter-notify (call-hook enter-notify-hook event-slots)) - (:exposure (call-hook exposure-hook event-slots)))) - ;;(dbg "Ignore handle event" c event-slots))) - t)) + (let ((last-mode *current-event-mode*)) + (unassoc-keyword-handle-event) + (when original-mode + (dolist (add-mode (ensure-list original-mode)) + (assoc-keyword-handle-event add-mode))) + (assoc-keyword-handle-event mode) (nfuncall enter-function) (unwind-protect (catch exit-tag @@ -73,6 +42,8 @@ (call-hook loop-hook) (nfuncall loop-function) (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handler-function :timeout *loop-timeout*) + (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*) (xlib:display-finish-output *display*))) - (nfuncall leave-function)))) + (nfuncall leave-function) + (unassoc-keyword-handle-event) + (assoc-keyword-handle-event last-mode)))) Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Mon Aug 16 17:23:20 2010 @@ -274,83 +274,80 @@ (add-hook *binding-hook* 'set-default-info-mouse) -;;;,----- -;;;| Main mode -;;;`----- -(defun info-mode (info-list &key (width nil) (height nil)) - "Open the info mode. Info-list is a list of info: One string per line +(let (info) + (define-handler info-mode :key-press (code state) + (funcall-key-from-code *info-keys* code state info)) + + (define-handler info-mode :motion-notify (window root-x root-y) + (unless (compress-motion-notify) + (funcall-button-from-code *info-mouse* 'motion (modifiers->state *default-modifiers*) + window root-x root-y *fun-press* (list info)))) + + (define-handler info-mode :button-press (window root-x root-y code state) + (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info))) + + (define-handler info-mode :button-release (window root-x root-y code state) + (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info))) + + + + (defun info-mode (info-list &key (width nil) (height nil)) + "Open the info mode. Info-list is a list of info: One string per line Or for colored output: a list (line_string color) Or ((1_word color) (2_word color) 3_word (4_word color)...)" - (when info-list - (setf *info-selected-item* 0) - (labels ((compute-size (line) - (typecase line - (cons (typecase (first line) - (cons (let ((val 0)) - (dolist (l line val) - (incf val (typecase l - (cons (length (first l))) - (t (length l))))))) - (t (length (first line))))) - (t (length line))))) - (let* ((font (xlib:open-font *display* *info-font-string*)) - (ilw (xlib:max-char-width font)) - (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1)) - (width (or width - (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw) - (xlib:screen-width *screen*)))) - (height (or height - (min (round (+ (* (length info-list) ilh) (/ ilh 2))) - (xlib:screen-height *screen*))))) - (with-placement (*info-mode-placement* x y width height) - (let* ((pointer-grabbed-p (xgrab-pointer-p)) - (keyboard-grabbed-p (xgrab-keyboard-p)) - (window (xlib:create-window :parent *root* - :x x :y y - :width width - :height height + (when info-list + (setf *info-selected-item* 0) + (labels ((compute-size (line) + (typecase line + (cons (typecase (first line) + (cons (let ((val 0)) + (dolist (l line val) + (incf val (typecase l + (cons (length (first l))) + (t (length l))))))) + (t (length (first line))))) + (t (length line))))) + (let* ((font (xlib:open-font *display* *info-font-string*)) + (ilw (xlib:max-char-width font)) + (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1)) + (width (or width + (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw) + (xlib:screen-width *screen*)))) + (height (or height + (min (round (+ (* (length info-list) ilh) (/ ilh 2))) + (xlib:screen-height *screen*))))) + (with-placement (*info-mode-placement* x y width height) + (let* ((pointer-grabbed-p (xgrab-pointer-p)) + (keyboard-grabbed-p (xgrab-keyboard-p)) + (window (xlib:create-window :parent *root* + :x x :y y + :width width + :height height + :background (get-color *info-background*) + :colormap (xlib:screen-default-colormap *screen*) + :border-width 1 + :border (get-color *info-border*) + :event-mask '(:exposure))) + (gc (xlib:create-gcontext :drawable window + :foreground (get-color *info-foreground*) :background (get-color *info-background*) - :colormap (xlib:screen-default-colormap *screen*) - :border-width 1 - :border (get-color *info-border*) - :event-mask '(:exposure))) - (gc (xlib:create-gcontext :drawable window - :foreground (get-color *info-foreground*) - :background (get-color *info-background*) - :font font - :line-style :solid)) - (info (make-info :window window :gc gc :x 0 :y 0 :list info-list - :font font :ilw ilw :ilh ilh - :max-x (* (loop for l in info-list maximize (compute-size l)) ilw) - :max-y (* (length info-list) ilh)))) - (labels ((handle-key (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) - (funcall-key-from-code *info-keys* code state info)) - (handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys) - (declare (ignore event-slots)) - (unless (compress-motion-notify) - (funcall-button-from-code *info-mouse* 'motion (modifiers->state *default-modifiers*) - window root-x root-y *fun-press* (list info)))) - (handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys) - (declare (ignore event-slots)) - (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info))) - (handle-button-release (&rest event-slots &key window root-x root-y code state &allow-other-keys) - (declare (ignore event-slots)) - (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info)))) + :font font + :line-style :solid))) + (setf info (make-info :window window :gc gc :x 0 :y 0 :list info-list + :font font :ilw ilw :ilh ilh + :max-x (* (loop for l in info-list maximize (compute-size l)) ilw) + :max-y (* (length info-list) ilh))) (map-window window) (draw-info-window info) (xgrab-pointer *root* 68 69) (unless keyboard-grabbed-p (xgrab-keyboard *root*)) (wait-no-key-or-button-press) - (generic-mode 'exit-info-loop - :loop-function (lambda () - (raise-window (info-window info))) - :button-press-hook #'handle-button-press - :button-release-hook #'handle-button-release - :motion-notify-hook #'handle-motion-notify - :key-press-hook #'handle-key) + (generic-mode 'info-mode 'exit-info-loop + :loop-function (lambda () + (raise-window (info-window info))) + :original-mode '(main-mode)) (if pointer-grabbed-p (xgrab-pointer *root* 66 67) (xungrab-pointer)) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Mon Aug 16 17:23:20 2010 @@ -263,16 +263,13 @@ - -(defun query-handle-key (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) +(define-handler query-mode :key-press (code state) (unless (funcall-key-from-code *query-keys* code state) (add-in-query-string code state)) (query-print-string)) - (defun query-string (message &optional (default "")) "Query a string from the keyboard. Display msg as prompt" (let ((grab-keyboard-p (xgrab-keyboard-p)) @@ -284,11 +281,11 @@ (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) - (generic-mode 'exit-query-loop + (generic-mode 'query-mode 'exit-query-loop :enter-function #'query-enter-function :loop-function #'query-loop-function :leave-function #'query-leave-function - :key-press-hook #'query-handle-key) + :original-mode '(main-mode)) (unless grab-keyboard-p (xungrab-keyboard) (grab-main-keys)) Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Mon Aug 16 17:23:20 2010 @@ -47,153 +47,54 @@ -;;; Second mode hooks -(defun sm-handle-key-press (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) +;;; Second mode handlers +(define-handler second-mode :key-press (code state) (funcall-key-from-code *second-keys* code state) (draw-second-mode-window)) -(defun sm-handle-enter-notify (&rest event-slots &key root-x root-y &allow-other-keys) - (declare (ignore event-slots root-x root-y)) - ;; (focus-frame-under-mouse root-x root-y) +(define-handler second-mode :enter-notify () (draw-second-mode-window)) -(defun sm-handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys) - (declare (ignore event-slots)) +(define-handler second-mode :motion-notify (window root-x root-y) (unless (compress-motion-notify) (funcall-button-from-code *second-mouse* 'motion (modifiers->state *default-modifiers*) window root-x root-y *fun-press*))) -(defun sm-handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys) - (declare (ignore event-slots)) +(define-handler second-mode :button-press (window root-x root-y code state) (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-press*) (draw-second-mode-window)) -(defun sm-handle-button-release (&rest event-slots &key window root-x root-y code state &allow-other-keys) - (declare (ignore event-slots)) +(define-handler second-mode :button-release (window root-x root-y code state) (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-release*) (draw-second-mode-window)) -(defun sm-handle-configure-request (&rest event-slots) - (apply #'handle-configure-request event-slots) +(define-handler second-mode :configure-request () + (apply #'handle-event-fun-main-mode-configure-request event-slots) (draw-second-mode-window)) -(defun sm-handle-configure-notify (&rest event-slots) - (apply #'handle-configure-notify event-slots) +(define-handler second-mode :configure-notify () (draw-second-mode-window)) -(defun sm-handle-destroy-notify (&rest event-slots) - (apply #'handle-destroy-notify event-slots) - (draw-second-mode-window)) - -(defun sm-handle-map-request (&rest event-slots) - (apply #'handle-map-request event-slots) - (draw-second-mode-window)) - -(defun sm-handle-unmap-notify (&rest event-slots) - (apply #'handle-unmap-notify event-slots) - (draw-second-mode-window)) - -(defun sm-handle-exposure (&rest event-slots) - (apply #'handle-exposure event-slots) - (draw-second-mode-window)) - - - -;;(defun sm-handle-property-notify (&rest event-slots &key window &allow-other-keys) -;; ;;(dbg (xlib:wm-name window)) -;; (draw-second-mode-window)) - - -;;; CONFIG: Second mode hooks -(setf *sm-button-press-hook* 'sm-handle-button-press - *sm-button-release-hook* 'sm-handle-button-release - *sm-motion-notify-hook* 'sm-handle-motion-notify - *sm-key-press-hook* 'sm-handle-key-press - *sm-configure-request-hook* 'sm-handle-configure-request - *sm-configure-notify-hook* 'sm-handle-configure-notify - *sm-destroy-notify-hook* 'sm-handle-destroy-notify - *sm-enter-notify-hook* 'sm-handle-enter-notify - *sm-exposure-hook* 'sm-handle-exposure - *sm-map-request-hook* 'sm-handle-map-request - *sm-unmap-notify-hook* 'sm-handle-unmap-notify) +(define-handler second-mode :destroy-notify () + (apply #'handle-event-fun-main-mode-destroy-notify event-slots) + (draw-second-mode-window)) +(define-handler second-mode :map-request () + (apply #'handle-event-fun-main-mode-map-request event-slots) + (draw-second-mode-window)) +(define-handler second-mode :unmap-notify () + (apply #'handle-event-fun-main-mode-unmap-notify event-slots) + (draw-second-mode-window)) +(define-handler second-mode :exposure () + (apply #'handle-event-fun-main-mode-exposure event-slots) + (draw-second-mode-window)) -;;(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys) -;; (declare (ignore display)) -;; ;; (dbg event-key) -;; (with-xlib-protect -;; (case event-key -;; (:button-press (call-hook *sm-button-press-hook* event-slots)) -;; (:button-release (call-hook *sm-button-release-hook* event-slots)) -;; (:motion-notify (call-hook *sm-motion-notify-hook* event-slots)) -;; (:key-press (call-hook *sm-key-press-hook* event-slots)) -;; (:configure-request (call-hook *sm-configure-request-hook* event-slots)) -;; (:configure-notify (call-hook *sm-configure-notify-hook* event-slots)) -;; (:map-request (call-hook *sm-map-request-hook* event-slots)) -;; (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots)) -;; (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots)) -;; (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots)) -;; (:property-notify (call-hook *sm-property-notify-hook* event-slots)) -;; (:create-notify (call-hook *sm-create-notify-hook* event-slots)) -;; (:enter-notify (call-hook *sm-enter-notify-hook* event-slots)) -;; (:exposure (call-hook *sm-exposure-hook* event-slots)))) -;; ;;(dbg "Ignore handle event" c event-slots))) -;; t) - - - -;;(defun second-key-mode () -;; "Switch to editing mode" -;; ;;(dbg "Second key ignore" c))))) -;; (setf *in-second-mode* t -;; *sm-window* (xlib:create-window :parent *root* -;; :x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2)) -;; :y 0 -;; :width *sm-width* :height *sm-height* -;; :background (get-color *sm-background-color*) -;; :border-width 1 -;; :border (get-color *sm-border-color*) -;; :colormap (xlib:screen-default-colormap *screen*) -;; :event-mask '(:exposure)) -;; *sm-font* (xlib:open-font *display* *sm-font-string*) -;; *sm-gc* (xlib:create-gcontext :drawable *sm-window* -;; :foreground (get-color *sm-foreground-color*) -;; :background (get-color *sm-background-color*) -;; :font *sm-font* -;; :line-style :solid)) -;; (xlib:map-window *sm-window*) -;; (draw-second-mode-window) -;; (no-focus) -;; (ungrab-main-keys) -;; (xgrab-keyboard *root*) -;; (xgrab-pointer *root* 66 67) -;; (unwind-protect -;; (catch 'exit-second-loop -;; (loop -;; (raise-window *sm-window*) -;; (xlib:display-finish-output *display*) -;; (xlib:process-event *display* :handler #'sm-handle-event) -;; (xlib:display-finish-output *display*))) -;; (xlib:free-gcontext *sm-gc*) -;; (xlib:close-font *sm-font*) -;; (xlib:destroy-window *sm-window*) -;; (xungrab-keyboard) -;; (xungrab-pointer) -;; (grab-main-keys) -;; (show-all-children) -;; (display-all-frame-info)) -;; (wait-no-key-or-button-press) -;; (when *second-mode-program* -;; (do-shell *second-mode-program*) -;; (setf *second-mode-program* nil)) -;; (setf *in-second-mode* nil)) (defun sm-enter-function () @@ -238,29 +139,13 @@ (setf *second-mode-program* nil)) (setf *in-second-mode* nil)) - (defun second-key-mode () "Switch to editing mode" - (generic-mode 'exit-second-loop + (generic-mode 'second-mode + 'exit-second-loop :enter-function #'sm-enter-function :loop-function #'sm-loop-function - :leave-function #'sm-leave-function - :button-press-hook *sm-button-press-hook* - :button-release-hook *sm-button-release-hook* - :key-press-hook *sm-key-press-hook* - :key-release-hook *sm-key-release-hook* - :motion-notify-hook *sm-motion-notify-hook* - :configure-request-hook *sm-configure-request-hook* - :configure-notify-hook *sm-configure-notify-hook* - :map-request-hook *sm-map-request-hook* - :unmap-notify-hook *sm-unmap-notify-hook* - :destroy-notify-hook *sm-destroy-notify-hook* - :mapping-notify-hook *sm-mapping-notify-hook* - :property-notify-hook *sm-property-notify-hook* - :create-notify-hook *sm-create-notify-hook* - :enter-notify-hook *sm-enter-notify-hook* - :exposure-hook *sm-exposure-hook*)) - + :leave-function #'sm-leave-function)) (defun leave-second-mode () "Leave second mode" Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Mon Aug 16 17:23:20 2010 @@ -680,13 +680,6 @@ ;;;;;,----- ;;;;;| Various definitions ;;;;;`----- -;;(defun stop-all-pending-actions () -;; "Stop all pending actions (actions like open in new workspace/frame)" -;; (setf *open-next-window-in-new-workspace* nil -;; *open-next-window-in-new-frame* nil -;; *arrow-action* nil -;; *pager-arrow-action* nil)) -;; (defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html")) "Show current keys and buttons bindings" Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Mon Aug 16 17:23:20 2010 @@ -26,38 +26,24 @@ (in-package :clfswm) - - - -;;; Main mode hooks -(defun handle-key-press (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) +(define-handler main-mode :key-press (code state) (funcall-key-from-code *main-keys* code state)) - -(defun handle-button-press (&rest event-slots &key code state window root-x root-y &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :button-press (code state window root-x root-y) (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-press*) (replay-button-event))) - - -(defun handle-button-release (&rest event-slots &key code state window root-x root-y &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :button-release (code state window root-x root-y) (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-release*) (replay-button-event))) -(defun handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :motion-notify (window root-x root-y) (unless (compress-motion-notify) (funcall-button-from-code *main-mouse* 'motion (modifiers->state *default-modifiers*) window root-x root-y *fun-press*))) - -(defun handle-configure-request (&rest event-slots &key stack-mode #|parent|# window #|above-sibling|# - x y width height border-width value-mask &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :configure-request (stack-mode window x y width height border-width value-mask) (labels ((has-x (mask) (= 1 (logand mask 1))) (has-y (mask) (= 2 (logand mask 2))) (has-w (mask) (= 4 (logand mask 4))) @@ -86,17 +72,7 @@ (case stack-mode (:above (raise-window window)))))))) - - - -(defun handle-configure-notify (&rest event-slots) - (declare (ignore event-slots))) - - - - -(defun handle-map-request (&rest event-slots &key window send-event-p &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :map-request (window send-event-p) (unless send-event-p (unhide-window window) (process-new-window window) @@ -104,29 +80,21 @@ (unless (null-size-window-p window) (show-all-children)))) - - -(defun handle-unmap-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :unmap-notify (send-event-p event-window window) (unless (and (not send-event-p) (not (xlib:window-equal window event-window))) (when (find-child window *root-frame*) (delete-child-in-all-frames window) (show-all-children)))) - -(defun handle-destroy-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :destroy-notify (send-event-p event-window window) (unless (or send-event-p (xlib:window-equal window event-window)) (when (find-child window *root-frame*) (delete-child-in-all-frames window) (show-all-children)))) - - -(defun handle-enter-notify (&rest event-slots &key window root-x root-y &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :enter-notify (window root-x root-y) (unless (and (> root-x (- (xlib:screen-width *screen*) 3)) (> root-y (- (xlib:screen-height *screen*) 3))) (case (if (frame-p *current-child*) @@ -146,62 +114,11 @@ (focus-all-children child parent) (show-all-children))))))) - - - -(defun handle-exposure (&rest event-slots &key window &allow-other-keys) - (declare (ignore event-slots)) +(define-handler main-mode :exposure (window) (awhen (find-frame-window window *current-root*) (display-frame-info it))) -(defun handle-create-notify (&rest event-slots) - (declare (ignore event-slots))) - - - - - -;;; CONFIG: Main mode hooks -(setf *key-press-hook* 'handle-key-press - *configure-request-hook* 'handle-configure-request - *configure-notify-hook* 'handle-configure-notify - *destroy-notify-hook* 'handle-destroy-notify - *enter-notify-hook* 'handle-enter-notify - *exposure-hook* 'handle-exposure - *map-request-hook* 'handle-map-request - *unmap-notify-hook* 'handle-unmap-notify - *create-notify-hook* 'handle-create-notify - *button-press-hook* 'handle-button-press - *button-release-hook* 'handle-button-release - *motion-notify-hook* 'handle-motion-notify) - - - - -(defun handle-event (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - ;;(dbg event-key) - (with-xlib-protect - (case event-key - (:button-press (call-hook *button-press-hook* event-slots)) - (:button-release (call-hook *button-release-hook* event-slots)) - (:motion-notify (call-hook *motion-notify-hook* event-slots)) - (:key-press (call-hook *key-press-hook* event-slots)) - (:configure-request (call-hook *configure-request-hook* event-slots)) - (:configure-notify (call-hook *configure-notify-hook* event-slots)) - (:map-request (call-hook *map-request-hook* event-slots)) - (:unmap-notify (call-hook *unmap-notify-hook* event-slots)) - (:destroy-notify (call-hook *destroy-notify-hook* event-slots)) - (:mapping-notify (call-hook *mapping-notify-hook* event-slots)) - (:property-notify (call-hook *property-notify-hook* event-slots)) - (:create-notify (call-hook *create-notify-hook* event-slots)) - (:enter-notify (call-hook *enter-notify-hook* event-slots)) - (:exposure (call-hook *exposure-hook* event-slots)))) - t) - - - (defun main-loop () (loop (with-xlib-protect @@ -226,6 +143,7 @@ (defun init-display () + (assoc-keyword-handle-event 'main-mode) (setf *screen* (first (xlib:display-roots *display*)) *root* (xlib:screen-root *screen*) *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1) @@ -326,7 +244,9 @@ (ungrab-main-keys) (xlib:destroy-window *no-focus-window*) (xlib:free-pixmap *pixmap-buffer*) - (xlib:close-display *display*))) + (xlib:close-display *display*) + #+:event-debug + (format t "~2&Unhandled events: ~A~%" *unhandled-events*))) (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Mon Aug 16 17:23:20 2010 @@ -173,70 +173,6 @@ (defparameter *menu* (make-menu :name 'main :doc "Main menu")) -;;; Main mode hooks (set in clfswm.lisp) -(defparameter *button-press-hook* nil - "Config(Hook group):") -(defparameter *button-release-hook* nil - "Config(Hook group):") -(defparameter *motion-notify-hook* nil - "Config(Hook group):") -(defparameter *key-press-hook* nil - "Config(Hook group):") -(defparameter *key-release-hook* nil - "Config(Hook group):") -(defparameter *configure-request-hook* nil - "Config(Hook group):") -(defparameter *configure-notify-hook* nil - "Config(Hook group):") -(defparameter *create-notify-hook* nil - "Config(Hook group):") -(defparameter *destroy-notify-hook* nil - "Config(Hook group):") -(defparameter *enter-notify-hook* nil - "Config(Hook group):") -(defparameter *exposure-hook* nil - "Config(Hook group):") -(defparameter *map-request-hook* nil - "Config(Hook group):") -(defparameter *mapping-notify-hook* nil - "Config(Hook group):") -(defparameter *property-notify-hook* nil - "Config(Hook group):") -(defparameter *unmap-notify-hook* nil - "Config(Hook group):") - - -;;; Second mode hooks (set in clfswm-second-mode.lisp) -(defparameter *sm-button-press-hook* nil - "Config(Hook group):") -(defparameter *sm-button-release-hook* nil - "Config(Hook group):") -(defparameter *sm-motion-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-key-press-hook* nil - "Config(Hook group):") -(defparameter *sm-key-release-hook* nil - "Config(Hook group):") -(defparameter *sm-configure-request-hook* nil - "Config(Hook group):") -(defparameter *sm-configure-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-map-request-hook* nil - "Config(Hook group):") -(defparameter *sm-unmap-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-destroy-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-mapping-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-property-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-create-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-enter-notify-hook* nil - "Config(Hook group):") -(defparameter *sm-exposure-hook* nil - "Config(Hook group):") (defparameter *binding-hook* nil Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Mon Aug 16 17:23:20 2010 @@ -34,6 +34,7 @@ :nfuncall :pfuncall :symbol-search + :symb :call-hook :add-hook :remove-hook @@ -127,6 +128,16 @@ "Search the string 'search' in the symbol name of 'symbol'" (search search (symbol-name symbol) :test #'string-equal)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (a args) + (princ a s)))) + + (defun symb (&rest args) + (values (intern (apply #'mkstr args))))) + + ;;;,----- ;;;| Minimal hook ;;;`----- Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Mon Aug 16 17:23:20 2010 @@ -70,7 +70,84 @@ , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) (declare (ignore c))))) - ;;(dbg c ',body)))) +;;(dbg c ',body)))) + + + + +;;; +;;; Events management functions. +;;; +(defparameter *unhandled-events* nil) +(defparameter *current-event-mode* nil) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun keyword->handle-event (mode keyword) + (symb 'handle-event-fun "-" mode "-" keyword))) + +(defun handle-event->keyword (symbol) + (let* ((name (string-downcase (symbol-name symbol))) + (pos (search "handle-event-fun-" name))) + (when (and pos (zerop pos)) + (let ((pos-mod (search "mode" name))) + (when pos-mod + (values (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword) + (subseq name (length "handle-event-fun-") (1- pos-mod)))))))) + + +(defmacro with-handle-event-symbol ((mode) &body body) + "Bind symbol to all handle event functions available in mode" + `(let ((pattern (format nil "handle-event-fun-~A" ,mode))) + (with-all-internal-symbols (symbol :clfswm) + (let ((pos (symbol-search pattern symbol))) + (when (and pos (zerop pos)) + , at body))))) + + +(defun find-handle-event-function (&optional (mode "")) + "Print all handle event functions available in mode" + (with-handle-event-symbol (mode) + (print symbol))) + +(defun assoc-keyword-handle-event (mode) + "Associate all keywords in mode to their corresponding handle event functions. +For example: main-mode :key-press is bound to handle-event-fun-main-mode-key-press" + (setf *current-event-mode* mode) + (with-handle-event-symbol (mode) + (let ((keyword (handle-event->keyword symbol))) + (when (fboundp symbol) + #+:event-debug + (format t "~&Associating: ~S with ~S~%" symbol keyword) + (setf (symbol-function keyword) (symbol-function symbol)))))) + +(defun unassoc-keyword-handle-event (&optional (mode "")) + "Unbound all keywords from their corresponding handle event functions." + (setf *current-event-mode* nil) + (with-handle-event-symbol (mode) + (let ((keyword (handle-event->keyword symbol))) + (when (fboundp keyword) + #+:event-debug + (format t "~&Unassociating: ~S ~S~%" symbol keyword) + (fmakunbound keyword))))) + +(defmacro define-handler (mode keyword args &body body) + "Like a defun but with a name expanded as handle-event-fun-'mode'-'keyword' +For example (define-handler main-mode :key-press (args) ...) +Expand in handle-event-fun-main-mode-key-press" + `(defun ,(keyword->handle-event mode keyword) (&rest event-slots &key #+:event-debug event-key , at args &allow-other-keys) + (declare (ignorable event-slots)) + #+:event-debug (print (list *current-event-mode* event-key)) + , at body)) + + +(defun handle-event (&rest event-slots &key event-key &allow-other-keys) + (with-xlib-protect + (if (fboundp event-key) + (apply event-key event-slots) + #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) + t) + + @@ -241,21 +318,6 @@ ;; ;;(defsetf net-wm-state (window &key (mode :replace)) (states) ;; `(set-atoms-property ,window ,states :_NET_WM_STATE :mode ,mode)) -;; -;; -;; -;;(defun hide-window (window) -;; (when window -;; (with-xlib-protect -;; (let ((net-wm-state (net-wm-state window))) -;; (dbg net-wm-state) -;; (pushnew :_net_wm_state_hidden net-wm-state) -;; (setf (net-wm-state window) net-wm-state) -;; (dbg (net-wm-state window))) -;; (setf (window-state window) +iconic-state+ -;; (xlib:window-event-mask window) (remove :structure-notify *window-events*)) -;; (xlib:unmap-window window) -;; (setf (xlib:window-event-mask window) *window-events*)))) (defun hide-window (window) @@ -429,32 +491,6 @@ (defun ungrab-all-keys (window) (xlib:ungrab-key window :any :modifiers :any)) -;;(defun grab-all-keys (window) -;; (ungrab-all-keys window) -;; (dolist (modifiers '(:control :mod-1 :shift)) -;; (xlib:grab-key window :any -;; :modifiers (list modifiers) -;; :owner-p nil -;; :sync-pointer-p nil -;; :sync-keyboard-p t))) - -;;(defun grab-all-keys (window) -;; (ungrab-all-keys window) -;; (xlib:grab-key window :any -;; :modifiers :any -;; :owner-p nil -;; :sync-pointer-p nil -;; :sync-keyboard-p t)) - - - - -;;(defun stop-keyboard-event () -;; (xlib:allow-events *display* :sync-keyboard)) -;; -;;(defun replay-keyboard-event () -;; (xlib:allow-events *display* :replay-keyboard)) - (defun stop-button-event () (xlib:allow-events *display* :sync-pointer)) @@ -468,114 +504,88 @@ + + ;;; Mouse action on window -(defun move-window (window orig-x orig-y &optional additional-fn additional-arg) - (raise-window window) - (let ((done nil) - (dx (- (xlib:drawable-x window) orig-x)) - (dy (- (xlib:drawable-y window) orig-y)) - (pointer-grabbed-p (xgrab-pointer-p))) - (labels ((motion-notify (&rest event-slots &key root-x root-y &allow-other-keys) - (declare (ignore event-slots)) - (unless (compress-motion-notify) - (setf (xlib:drawable-x window) (+ root-x dx) - (xlib:drawable-y window) (+ root-y dy)) - (when additional-fn - (apply additional-fn additional-arg)))) - (handle-event (&rest event-slots &key event-key &allow-other-keys) - (case event-key - (:motion-notify (apply #'motion-notify event-slots)) - (:button-release (setf done t)) - (:configure-request (call-hook *configure-request-hook* event-slots)) - (:configure-notify (call-hook *configure-notify-hook* event-slots)) - (:map-request (call-hook *map-request-hook* event-slots)) - (:unmap-notify (call-hook *unmap-notify-hook* event-slots)) - (:destroy-notify (call-hook *destroy-notify-hook* event-slots)) - (:mapping-notify (call-hook *mapping-notify-hook* event-slots)) - (:property-notify (call-hook *property-notify-hook* event-slots)) - (:create-notify (call-hook *create-notify-hook* event-slots))) - t)) +(let (add-fn add-arg dx dy window) + (define-handler move-window-mode :motion-notify (root-x root-y) + (unless (compress-motion-notify) + (setf (xlib:drawable-x window) (+ root-x dx) + (xlib:drawable-y window) (+ root-y dy)) + (when add-fn + (apply add-fn add-arg)))) + + (define-handler move-window-mode :button-release () + (throw 'exit-move-window-mode nil)) + + (defun move-window (orig-window orig-x orig-y &optional additional-fn additional-arg) + (setf window orig-window + add-fn additional-fn + add-arg additional-arg + dx (- (xlib:drawable-x window) orig-x) + dy (- (xlib:drawable-y window) orig-y)) + (raise-window window) + (let ((pointer-grabbed-p (xgrab-pointer-p))) (unless pointer-grabbed-p (xgrab-pointer *root* nil nil)) (when additional-fn (apply additional-fn additional-arg)) - (loop until done - do (with-xlib-protect - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*))) + (generic-mode 'move-window-mode 'exit-move-window-mode + :original-mode '(main-mode)) (unless pointer-grabbed-p (xungrab-pointer))))) -(defun resize-window (window orig-x orig-y &optional additional-fn additional-arg) - (raise-window window) - (let* ((done nil) - (orig-width (xlib:drawable-width window)) - (orig-height (xlib:drawable-height window)) - (pointer-grabbed-p (xgrab-pointer-p)) - (hints (xlib:wm-normal-hints window)) - (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0)) - (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0)) - (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) most-positive-fixnum)) - (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) most-positive-fixnum))) - (labels ((motion-notify (&rest event-slots &key root-x root-y &allow-other-keys) - (declare (ignore event-slots)) - (unless (compress-motion-notify) - (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x orig-x)) 10 min-width) max-width) - (xlib:drawable-height window) (min (max (+ orig-height (- root-y orig-y)) 10 min-height) max-height)) - (when additional-fn - (apply additional-fn additional-arg)))) - (handle-event (&rest event-slots &key event-key &allow-other-keys) - (case event-key - (:motion-notify (apply #'motion-notify event-slots)) - (:button-release (setf done t)) - (:configure-request (call-hook *configure-request-hook* event-slots)) - (:configure-notify (call-hook *configure-notify-hook* event-slots)) - (:map-request (call-hook *map-request-hook* event-slots)) - (:unmap-notify (call-hook *unmap-notify-hook* event-slots)) - (:destroy-notify (call-hook *destroy-notify-hook* event-slots)) - (:mapping-notify (call-hook *mapping-notify-hook* event-slots)) - (:property-notify (call-hook *property-notify-hook* event-slots)) - (:create-notify (call-hook *create-notify-hook* event-slots))) - t)) +(let (add-fn add-arg window + o-x o-y + orig-width orig-height + min-width max-width + min-height max-height) + (define-handler resize-window-mode :motion-notify (root-x root-y) + (unless (compress-motion-notify) + (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width) + (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height)) + (when add-fn + (apply add-fn add-arg)))) + + (define-handler resize-window-mode :button-release () + (throw 'exit-resize-window-mode nil)) + + (defun resize-window (orig-window orig-x orig-y &optional additional-fn additional-arg) + (let* ((pointer-grabbed-p (xgrab-pointer-p)) + (hints (xlib:wm-normal-hints orig-window))) + (setf window orig-window + add-fn additional-fn + add-arg additional-arg + o-x orig-x + o-y orig-y + orig-width (xlib:drawable-width window) + orig-height (xlib:drawable-height window) + min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0) + min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0) + max-width (or (and hints (xlib:wm-size-hints-max-width hints)) most-positive-fixnum) + max-height (or (and hints (xlib:wm-size-hints-max-height hints)) most-positive-fixnum)) + (raise-window window) (unless pointer-grabbed-p (xgrab-pointer *root* nil nil)) (when additional-fn (apply additional-fn additional-arg)) - (loop until done - do (with-xlib-protect - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*))) + (generic-mode 'resize-window-mode 'exit-resize-window-mode + :original-mode '(main-mode)) (unless pointer-grabbed-p (xungrab-pointer))))) - - +(define-handler wait-mouse-button-release-mode :button-release () + (throw 'exit-wait-mouse-button-release-mode nil)) (defun wait-mouse-button-release (&optional cursor-char cursor-mask-char) - (let ((done nil) - (pointer-grabbed-p (xgrab-pointer-p))) - (labels ((handle-event (&rest event-slots &key event-key &allow-other-keys) - (case event-key - (:button-release (setf done t)) - (:configure-request (call-hook *configure-request-hook* event-slots)) - (:configure-notify (call-hook *configure-notify-hook* event-slots)) - (:map-request (call-hook *map-request-hook* event-slots)) - (:unmap-notify (call-hook *unmap-notify-hook* event-slots)) - (:destroy-notify (call-hook *destroy-notify-hook* event-slots)) - (:mapping-notify (call-hook *mapping-notify-hook* event-slots)) - (:property-notify (call-hook *property-notify-hook* event-slots)) - (:create-notify (call-hook *create-notify-hook* event-slots))) - t)) - (unless pointer-grabbed-p - (xgrab-pointer *root* cursor-char cursor-mask-char)) - (loop until done - do (with-xlib-protect - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*))) - (unless pointer-grabbed-p - (xungrab-pointer))))) + (let ((pointer-grabbed-p (xgrab-pointer-p))) + (unless pointer-grabbed-p + (xgrab-pointer *root* cursor-char cursor-mask-char)) + (generic-mode 'wait-mouse-button-release 'exit-wait-mouse-button-release-mode) + (unless pointer-grabbed-p + (xungrab-pointer)))) From pbrochard at common-lisp.net Mon Aug 16 21:47:24 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 16 Aug 2010 17:47:24 -0400 Subject: [clfswm-cvs] r290 - clfswm/src Message-ID: Author: pbrochard Date: Mon Aug 16 17:47:24 2010 New Revision: 290 Log: Date copyright and version update Modified: clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-autodoc.lisp clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-configuration.lisp clfswm/src/clfswm-corner.lisp clfswm/src/clfswm-generic-mode.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-keys.lisp clfswm/src/clfswm-layout.lisp clfswm/src/clfswm-menu.lisp clfswm/src/clfswm-nw-hooks.lisp clfswm/src/clfswm-pack.lisp clfswm/src/clfswm-placement.lisp clfswm/src/clfswm-query.lisp clfswm/src/clfswm-second-mode.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/config.lisp clfswm/src/menu-def.lisp clfswm/src/my-html.lisp clfswm/src/netwm-util.lisp clfswm/src/package.lisp clfswm/src/tools.lisp clfswm/src/version.lisp clfswm/src/xlib-util.lisp Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Mon Aug 16 17:47:24 2010 @@ -7,7 +7,7 @@ ;;; Note: Mod-1 is the Alt or Meta key, Mod-2 is the Numlock key. ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Mon Aug 16 17:47:24 2010 @@ -7,7 +7,7 @@ ;;; Note: Mod-1 is the Alt or Meta key, Mod-2 is the Numlock key. ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-autodoc.lisp ============================================================================== --- clfswm/src/clfswm-autodoc.lisp (original) +++ clfswm/src/clfswm-autodoc.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Auto documentation tools ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-configuration.lisp ============================================================================== --- clfswm/src/clfswm-configuration.lisp (original) +++ clfswm/src/clfswm-configuration.lisp Mon Aug 16 17:47:24 2010 @@ -6,7 +6,7 @@ ;;; ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-corner.lisp ============================================================================== --- clfswm/src/clfswm-corner.lisp (original) +++ clfswm/src/clfswm-corner.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Corner functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- clfswm/src/clfswm-generic-mode.lisp (original) +++ clfswm/src/clfswm-generic-mode.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Info function (see the end of this file for user definition ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Keys functions definition ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Layout functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-menu.lisp ============================================================================== --- clfswm/src/clfswm-menu.lisp (original) +++ clfswm/src/clfswm-menu.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Menu functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-nw-hooks.lisp ============================================================================== --- clfswm/src/clfswm-nw-hooks.lisp (original) +++ clfswm/src/clfswm-nw-hooks.lisp Mon Aug 16 17:47:24 2010 @@ -8,7 +8,7 @@ ;;; mapped. ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-pack.lisp ============================================================================== --- clfswm/src/clfswm-pack.lisp (original) +++ clfswm/src/clfswm-pack.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Tile, pack and fill functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -45,7 +45,7 @@ (<= (frame-x frame) (frame-x2 current-frame))) (setf y-found (max y-found (frame-y2 frame))))) y-found)) - + (defun find-edge-down (current-frame parent) (let ((y-found 1)) (dolist (frame (frame-child parent)) @@ -56,7 +56,7 @@ (<= (frame-x frame) (frame-x2 current-frame))) (setf y-found (min y-found (frame-y frame))))) y-found)) - + (defun find-edge-right (current-frame parent) (let ((x-found 1)) (dolist (frame (frame-child parent)) @@ -67,7 +67,7 @@ (<= (frame-y frame) (frame-y2 current-frame))) (setf x-found (min x-found (frame-x frame))))) x-found)) - + (defun find-edge-left (current-frame parent) (let ((x-found 0)) @@ -176,7 +176,7 @@ (dx (- (frame-w frame) new-size))) (setf (frame-w frame) new-size) (incf (frame-x frame) (max dx 0)))) - + (defun resize-half-height-up (frame) (setf (frame-h frame) (/ (frame-h frame) 2))) @@ -186,7 +186,7 @@ (dy (- (frame-h frame) new-size))) (setf (frame-h frame) new-size) (incf (frame-y frame) (max dy 0)))) - + Modified: clfswm/src/clfswm-placement.lisp ============================================================================== --- clfswm/src/clfswm-placement.lisp (original) +++ clfswm/src/clfswm-placement.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Placement functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Query utility ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Second mode functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Utility ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Mon Aug 16 17:47:24 2010 @@ -10,7 +10,7 @@ ;;; (you can do a 'grep CONFIG *.lisp' to see what you can configure) ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Mon Aug 16 17:47:24 2010 @@ -7,7 +7,7 @@ ;;; Note: Mod-1 is the Alt or Meta key, Mod-2 is the Numlock key. ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/my-html.lisp ============================================================================== --- clfswm/src/my-html.lisp (original) +++ clfswm/src/my-html.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Html generator helper ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -83,7 +83,7 @@ (ul (li "toto") (li "klm")))))) - + (defun test2 () (with-html () @@ -114,7 +114,7 @@ (li "toto") (li "klm")))) 10)) - + Modified: clfswm/src/netwm-util.lisp ============================================================================== --- clfswm/src/netwm-util.lisp (original) +++ clfswm/src/netwm-util.lisp Mon Aug 16 17:47:24 2010 @@ -6,7 +6,7 @@ ;;; http://freedesktop.org/wiki/Specifications_2fwm_2dspec ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -27,7 +27,7 @@ (in-package :clfswm) -;;; Client List functions +;;; Client List functions (defun netwm-set-client-list (id-list) (xlib:change-property *root* :_NET_CLIENT_LIST id-list :window 32)) @@ -43,7 +43,7 @@ (netwm-set-client-list (remove (xlib:window-id window) (netwm-get-client-list)))) - + ;;; Desktop functions ;; +PHIL (defun netwm-update-desktop-property () ;; (xlib:change-property *root* :_NET_NUMBER_OF_DESKTOPS Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Package definition ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: General tools ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by Modified: clfswm/src/version.lisp ============================================================================== --- clfswm/src/version.lisp (original) +++ clfswm/src/version.lisp Mon Aug 16 17:47:24 2010 @@ -1,5 +1,5 @@ -;; Copyright (C) 2008 Xavier Maillard -;; Copyright (C) 2006 Martin Bishop +;; Copyright (C) 2010 Xavier Maillard +;; Copyright (C) 2010 Martin Bishop ;; ;; Borrowed from Stumpwm ;; This file is part of clfswm. @@ -33,4 +33,4 @@ (in-package :version) -(defparameter *version* #.(concatenate 'string "Version: 0906 built " (date-string))) +(defparameter *version* #.(concatenate 'string "Version: 1.0 built " (date-string))) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Mon Aug 16 17:47:24 2010 @@ -5,7 +5,7 @@ ;;; Documentation: Utility functions ;;; -------------------------------------------------------------------------- ;;; -;;; (C) 2005 Philippe Brochard +;;; (C) 2010 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by From pbrochard at common-lisp.net Mon Aug 16 21:50:24 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 16 Aug 2010 17:50:24 -0400 Subject: [clfswm-cvs] r291 - in clfswm: . doc Message-ID: Author: pbrochard Date: Mon Aug 16 17:50:24 2010 New Revision: 291 Log: Documentation update Modified: clfswm/doc/corner.html clfswm/doc/corner.txt clfswm/doc/keys.html clfswm/doc/keys.txt clfswm/doc/menu.html clfswm/doc/menu.txt clfswm/load.lisp Modified: clfswm/doc/corner.html ============================================================================== --- clfswm/doc/corner.html (original) +++ clfswm/doc/corner.html Mon Aug 16 17:50:24 2010 @@ -22,7 +22,7 @@ Top-Left: - --- + Open the main menu Modified: clfswm/doc/corner.txt ============================================================================== --- clfswm/doc/corner.txt (original) +++ clfswm/doc/corner.txt Mon Aug 16 17:50:24 2010 @@ -1,7 +1,7 @@ Here are the actions associated to screen corners in CLFSWM: *Corner-Main-Mode-Left-Button*: - Top-Left: --- + Top-Left: Open the main menu Top-Right: Present a virtual keyboard Bottom-Right: Present all windows in the current frame (An expose like) Bottom-Left: --- Modified: clfswm/doc/keys.html ============================================================================== --- clfswm/doc/keys.html (original) +++ clfswm/doc/keys.html Mon Aug 16 17:50:24 2010 @@ -208,10 +208,10 @@ - + Mod-1 - Menu + F10 Switch between two layouts @@ -219,10 +219,10 @@ - Mod-1 + Shift - Menu + F10 Show all frames info windows until a key is release @@ -230,10 +230,10 @@ - Shift + Mod-1 Shift - Menu + F10 Show all frames info windows @@ -244,7 +244,7 @@ Control - Menu + F10 Show/Hide the root frame @@ -487,7 +487,7 @@ 1 - Move the window under the mouse cursor to another frame + Move the child under the mouse cursor to another frame @@ -730,6 +730,17 @@ + Control + + + G + + + Leave second mode + + + + @@ -912,7 +923,7 @@ Menu - Show all frames info windows until a key is release + Show/Hide the root frame @@ -1027,7 +1038,7 @@ - + Control Delete @@ -1041,6 +1052,17 @@ + Delete + + + Delete the current child and its children in all frames + + + + + + + C @@ -1082,10 +1104,32 @@ + Mod-1 + + + F10 + + + Switch between two layouts + + + + Shift - Menu + F10 + + + Show all frames info windows until a key is release + + + + + Mod-1 Shift + + + F10 Show all frames info windows @@ -1096,7 +1140,7 @@ Control - Menu + F10 Show/Hide the root frame @@ -1295,7 +1339,7 @@ 1 - Move the window under the mouse cursor to another frame + Move the child under the mouse cursor to another frame @@ -1379,7 +1423,18 @@ Return - Leave the info mode + Leave the info mode and valid the selected item + + + + + + + + Space + + + Leave the info mode and valid the selected item @@ -1395,6 +1450,17 @@ + Control + + + G + + + Leave the info mode + + + + @@ -1518,7 +1584,8 @@ 1 - Begin grab text + + @@ -1537,6 +1604,17 @@ + 3 + + + Leave the info mode + + + + + + + 4 @@ -1562,7 +1640,8 @@ Motion - Grab text + + Modified: clfswm/doc/keys.txt ============================================================================== --- clfswm/doc/keys.txt (original) +++ clfswm/doc/keys.txt Mon Aug 16 17:50:24 2010 @@ -22,10 +22,10 @@ Mod-1 Page_down Raise the child in the current frame Mod-1 Home Switch to the root frame Mod-1 Shift Home Switch and select the root frame - Menu Switch between two layouts - Mod-1 Menu Show all frames info windows until a key is release - Shift Menu Show all frames info windows - Control Menu Show/Hide the root frame + Mod-1 F10 Switch between two layouts + Shift F10 Show all frames info windows until a key is release + Mod-1 Shift F10 Show all frames info windows + Control F10 Show/Hide the root frame Mod-1 B Move the pointer to the lower right corner of the screen Control Escape Close or kill the current window (ask before doing anything) Mod-1 T Switch to editing mode @@ -52,7 +52,7 @@ Or do actions on corners Mod-1 1 Move and focus the current child - Create a new frame on the root window Mod-1 3 Resize and focus the current child - Create a new frame on the root window - Mod-1 Control 1 Move the window under the mouse cursor to another frame + Mod-1 Control 1 Move the child under the mouse cursor to another frame 4 Select the next level in frame 5 Select the previous level in frame Mod-1 4 Enter in the selected frame - ie make it the root frame @@ -78,6 +78,7 @@ Exclam Run a program from the query input Return Leave second mode Escape Leave second mode + Control G Leave second mode T Tile the current frame Mod-1 Control Shift Home Exit clfswm Mod-1 Right Select the next brother @@ -94,7 +95,7 @@ Mod-1 Page_down Raise the child in the current frame Mod-1 Home Switch to the root frame Mod-1 Shift Home Switch and select the root frame - Menu Show all frames info windows until a key is release + Menu Show/Hide the root frame Mod-1 B Move the pointer to the lower right corner of the screen O Open the next window in a new frame in the parent frame Control O Open the next window in a new frame in the root frame @@ -105,13 +106,16 @@ Control C Copy the current child to the selection Control V Paste the selection in the current frame Control Shift V Paste the selection in the current frame - Do not clear the selection after paste - Delete Remove the current child from its parent frame + Control Delete Remove the current child from its parent frame + Delete Delete the current child and its children in all frames C start an xterm E start emacs Control E start an emacs for another user H start an xclock - Shift Menu Show all frames info windows - Control Menu Show/Hide the root frame + Mod-1 F10 Switch between two layouts + Shift F10 Show all frames info windows until a key is release + Mod-1 Shift F10 Show all frames info windows + Control F10 Show/Hide the root frame Mod-1 1 Bind or jump to a slot (a frame or a window) Mod-1 2 Bind or jump to a slot (a frame or a window) Mod-1 3 Bind or jump to a slot (a frame or a window) @@ -134,7 +138,7 @@ Or do corners actions Mod-1 1 Move and focus the current child - Create a new frame on the root window Mod-1 3 Resize and focus the current child - Create a new frame on the root window - Mod-1 Control 1 Move the window under the mouse cursor to another frame + Mod-1 Control 1 Move the child under the mouse cursor to another frame 4 Select the next level in frame 5 Select the previous level in frame Mod-1 4 Enter in the selected frame - ie make it the root frame @@ -145,8 +149,10 @@ -------------- Q Leave the info mode - Return Leave the info mode + Return Leave the info mode and valid the selected item + Space Leave the info mode and valid the selected item Escape Leave the info mode + Control G Leave the info mode Twosuperior Move the pointer to the lower right corner of the screen Down Move one line down Up Move one line up @@ -161,11 +167,12 @@ Mouse buttons actions in info mode: ---------------------------------- - 1 Begin grab text + 1 NIL 2 Leave the info mode + 3 Leave the info mode 4 Move one line up 5 Move one line down - Motion Grab text + Motion NIL Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Mon Aug 16 17:50:24 2010 @@ -45,867 +45,48 @@ y: < Utility menu >

- m: < CLFSWM menu > -

-
-

- Help-Menu -

-

- h: Show all key binding -

-

- b: Show the main mode binding -

-

- s: Show the second mode key binding -

-

- c: Help on clfswm corner -

-

- g: Show all configurable variables -

-

- d: Show the current time and date -

-

- p: Show current processes sorted by CPU usage -

-

- m: Show current processes sorted by memory usage -

-

- v: Show the current CLFSWM version -

-
-

- Standard-Menu -

-

- a: < WINDOW MANAGERS > -

-

- b: < APPLICATIONS > -

-

- c: < GAMES > -

-

- d: < HELP > -

-
-

- Window Managers -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-
-

- Applications -

-

- a: < SYSTEM > -

-

- b: < OFFICE > -

-

- c: < NETWORK > -

-

- d: < VIDEO > -

-

- e: < SCIENCE > -

-

- f: < SOUND > -

-

- g: < TERMINAL EMULATORS > -

-

- h: < VIEWERS > -

-

- i: < FILE MANAGEMENT > -

-

- j: < TEXT > -

-

- k: < GRAPHICS > -

-

- l: < EDITORS > -

-

- m: < DATA MANAGEMENT > -

-

- n: < PROGRAMMING > -

-

- o: < TOOLS > -

-

- p: < SHELLS > -

-

- q: < ACCESSIBILITY > -

-
-

- System -

-

- a: < HARDWARE > -

-

- b: < ADMINISTRATION > -

-

- c: < MONITORING > -

-

- d: < PACKAGE MANAGEMENT > -

-

- e: < SECURITY > -

-

- f: < LANGUAGE ENVIRONMENT > -

-

- g: X Window Snapshot -

-

- h: X Window Snapshot -

-
-

- Hardware -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-
-

- Administration -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-

- h: X Window Snapshot -

-

- i: X Window Snapshot -

-

- j: X Window Snapshot -

-

- k: X Window Snapshot -

-

- l: X Window Snapshot -

-

- m: X Window Snapshot -

-

- n: X Window Snapshot -

-

- o: X Window Snapshot -

-

- p: X Window Snapshot -

-

- q: X Window Snapshot -

-

- r: X Window Snapshot -

-

- s: X Window Snapshot -

-

- t: X Window Snapshot -

-

- u: X Window Snapshot -

-

- v: X Window Snapshot -

-

- w: X Window Snapshot -

-

- x: X Window Snapshot -

-

- y: X Window Snapshot -

-
-

- Monitoring -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-
-

- Package Management -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-
-

- Security -

-

- a: X Window Snapshot -

-
-

- Language Environment -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-

- h: X Window Snapshot -

-

- i: X Window Snapshot -

-

- j: X Window Snapshot -

-

- k: X Window Snapshot -

-

- l: X Window Snapshot -

-

- m: X Window Snapshot -

-

- n: X Window Snapshot -

-

- o: X Window Snapshot -

-

- p: X Window Snapshot -

-

- q: X Window Snapshot -

-

- r: X Window Snapshot -

-

- s: X Window Snapshot -

-
-

- Office -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-
-

- Network -

-

- a: < WEB BROWSING > -

-

- b: < COMMUNICATION > -

-

- c: < MONITORING > -

-

- d: < FILE TRANSFER > -

-

- e: < WEB NEWS > -

-
-

- Web Browsing -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-
-

- Communication -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-
-

- Monitoring -

-

- a: X Window Snapshot -

-
-

- File Transfer -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-
-

- Web News -

-

- a: X Window Snapshot -

-
-

- Video -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-
-

- Science -

-

- a: < MATHEMATICS > -

-
-

- Mathematics -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-
-

- Sound -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-

- h: X Window Snapshot -

-

- i: X Window Snapshot -

-

- j: X Window Snapshot -

-

- k: X Window Snapshot -

-

- l: X Window Snapshot -

-

- m: X Window Snapshot -

-

- n: X Window Snapshot -

-

- o: X Window Snapshot -

-

- p: X Window Snapshot -

-
-

- Terminal Emulators -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-
-

- Viewers -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-

- h: X Window Snapshot -

-

- i: X Window Snapshot -

-

- j: X Window Snapshot -

-
-

- File Management -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-
-

- Text -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-
-

- Graphics -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-
-

- Editors -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-
-

- Data Management -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-
-

- Programming -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-
-

- Tools -

-

- a: X Window Snapshot -

-
-

- Shells -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-
-

- Accessibility -

-

- a: X Window Snapshot -

-
-

- Games -

-

- a: < ACTION > -

-

- b: < BOARD > -

-

- c: < CARD > -

-

- d: < PUZZLES > -

-

- e: < BLOCKS > -

-

- f: < TOYS > -

-
-

- Action -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-
-

- Board -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-

- g: X Window Snapshot -

-
-

- Card -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-
-

- Puzzles -

-

- a: X Window Snapshot -

-

- b: X Window Snapshot -

-

- c: X Window Snapshot -

-

- d: X Window Snapshot -

-

- e: X Window Snapshot -

-

- f: X Window Snapshot -

-
-

- Blocks -

-

- a: X Window Snapshot + o: < Configuration menu >

- b: X Window Snapshot + m: < CLFSWM menu >

- Toys + Help-Menu

- a: X Window Snapshot -

-

- b: X Window Snapshot + h: Show all key binding

- c: X Window Snapshot + b: Show the main mode binding

- d: X Window Snapshot + s: Show the second mode key binding

- e: X Window Snapshot + c: Help on clfswm corner

- f: X Window Snapshot + g: Show all configurable variables

-
-

- Help -

- a: X Window Snapshot + d: Show the current time and date

- b: X Window Snapshot + p: Show current processes sorted by CPU usage

- c: X Window Snapshot + m: Show current processes sorted by memory usage

- d: X Window Snapshot + v: Show the current CLFSWM version

+ Standard-Menu +

+
+

Child-Menu

@@ -918,10 +99,10 @@ n: Ensure that all children numbers are unique

- x: Remove the current child from the CLFSWM tree + Delete: Delete the current child and its children in all frames

- Delete: Remove the current child from its parent frame + X: Remove the current child from its parent frame

h: Hide the current child @@ -1425,6 +606,350 @@

exclam: Run a program from the query input

+

+ o: < Other window manager menu > +

+
+

+ Other-Window-Manager-Menu +

+

+ x: Run xterm +

+

+ t: Run twm +

+

+ i: Run icewm +

+

+ g: Run Gnome +

+

+ k: Run KDE +

+

+ c: Run XFCE +

+

+ l: Run LXDE +

+

+ p: Prompt for an other window manager +

+
+

+ Configuration-Menu +

+

+ a: < Frame colors group > +

+

+ b: < Miscellaneous group > +

+

+ c: < Query string group > +

+

+ d: < Menu group > +

+

+ e: < Identify key group > +

+

+ f: < Main mode group > +

+

+ g: < Info mode group > +

+

+ h: < Corner group > +

+

+ i: < Hook group > +

+

+ j: < Placement group > +

+

+ k: < Circulate mode group > +

+

+ l: < Second mode group > +

+

+ F2: Save all configuration variables in clfswmrc +

+
+

+ Conf-Frame-Colors-Group +

+

+ a: Configure FRAME-FOREGROUND-ROOT +

+

+ b: Configure FRAME-FOREGROUND-HIDDEN +

+

+ c: Configure FRAME-FOREGROUND +

+

+ d: Configure FRAME-BACKGROUND +

+
+

+ Conf-Miscellaneous-Group +

+

+ a: Configure CREATE-FRAME-ON-ROOT +

+

+ b: Configure NEVER-MANAGED-WINDOW-LIST +

+

+ c: Configure DEFAULT-FONT-STRING +

+

+ d: Configure DEFAULT-MODIFIERS +

+

+ e: Configure DEFAULT-FOCUS-POLICY +

+

+ f: Configure DEFAULT-FRAME-DATA +

+

+ g: Configure LOOP-TIMEOUT +

+

+ h: Configure HAVE-TO-COMPRESS-NOTIFY +

+

+ i: Configure DEFAULT-WINDOW-WIDTH +

+

+ j: Configure DEFAULT-MANAGED-TYPE +

+

+ k: Configure DEFAULT-WINDOW-HEIGHT +

+
+

+ Conf-Query-String-Group +

+

+ a: Configure QUERY-BACKGROUND +

+

+ b: Configure QUERY-BORDER +

+

+ c: Configure QUERY-FONT-STRING +

+

+ d: Configure QUERY-FOREGROUND +

+
+

+ Conf-Menu-Group +

+

+ a: Configure MENU-COLOR-SUBMENU +

+

+ b: Configure MENU-COLOR-COMMENT +

+

+ c: Configure MENU-COLOR-MENU-KEY +

+

+ d: Configure MENU-COLOR-KEY +

+
+

+ Conf-Identify-Key-Group +

+

+ a: Configure IDENTIFY-FOREGROUND +

+

+ b: Configure IDENTIFY-BORDER +

+

+ c: Configure IDENTIFY-BACKGROUND +

+

+ d: Configure IDENTIFY-FONT-STRING +

+
+

+ Conf-Main-Mode-Group +

+

+ a: Configure COLOR-MAYBE-SELECTED +

+

+ b: Configure COLOR-SELECTED +

+

+ c: Configure COLOR-UNSELECTED +

+
+

+ Conf-Info-Mode-Group +

+

+ a: Configure INFO-BACKGROUND +

+

+ b: Configure INFO-FOREGROUND +

+

+ c: Configure INFO-BORDER +

+

+ d: Configure INFO-SELECTED-BACKGROUND +

+

+ e: Configure INFO-FONT-STRING +

+

+ f: Configure INFO-COLOR-UNDERLINE +

+

+ g: Configure INFO-COLOR-FIRST +

+

+ h: Configure INFO-LINE-CURSOR +

+

+ i: Configure INFO-COLOR-TITLE +

+

+ j: Configure INFO-CLICK-TO-SELECT +

+

+ k: Configure INFO-COLOR-SECOND +

+
+

+ Conf-Corner-Group +

+

+ a: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON +

+

+ b: Configure CORNER-MAIN-MODE-LEFT-BUTTON +

+

+ c: Configure VIRTUAL-KEYBOARD-KILL-CMD +

+

+ d: Configure CLFSWM-TERMINAL-CMD +

+

+ e: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON +

+

+ f: Configure VIRTUAL-KEYBOARD-CMD +

+

+ g: Configure CORNER-SECOND-MODE-LEFT-BUTTON +

+

+ h: Configure CORNER-SIZE +

+

+ i: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +

+

+ j: Configure CLFSWM-TERMINAL-NAME +

+

+ k: Configure CORNER-SECOND-MODE-RIGHT-BUTTON +

+
+

+ Conf-Hook-Group +

+

+ a: Configure INIT-HOOK +

+

+ b: Configure LOOP-HOOK +

+

+ c: Configure BINDING-HOOK +

+

+ d: Configure DEFAULT-NW-HOOK +

+
+

+ Conf-Placement-Group +

+

+ a: Configure BANISH-POINTER-PLACEMENT +

+

+ b: Configure SECOND-MODE-PLACEMENT +

+

+ c: Configure QUERY-MODE-PLACEMENT +

+

+ d: Configure INFO-MODE-PLACEMENT +

+

+ e: Configure CIRCULATE-MODE-PLACEMENT +

+
+

+ Conf-Circulate-Mode-Group +

+

+ a: Configure CIRCULATE-WIDTH +

+

+ b: Configure CIRCULATE-HEIGHT +

+

+ c: Configure CIRCULATE-FONT-STRING +

+

+ d: Configure CIRCULATE-FOREGROUND +

+

+ e: Configure CIRCULATE-TEXT-LIMITE +

+

+ f: Configure CIRCULATE-BACKGROUND +

+

+ g: Configure CIRCULATE-BORDER +

+
+

+ Conf-Second-Mode-Group +

+

+ a: Configure SM-FONT-STRING +

+

+ b: Configure SM-BACKGROUND-COLOR +

+

+ c: Configure SM-FOREGROUND-COLOR +

+

+ d: Configure SM-HEIGHT +

+

+ e: Configure SM-BORDER-COLOR +

+

+ f: Configure SM-WIDTH +

Clfswm-Menu Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Mon Aug 16 17:50:24 2010 @@ -11,6 +11,7 @@ n: < Action by name menu > u: < Action by number menu > y: < Utility menu > +o: < Configuration menu > m: < CLFSWM menu > Help-Menu @@ -25,313 +26,13 @@ v: Show the current CLFSWM version Standard-Menu -a: < WINDOW MANAGERS > -b: < APPLICATIONS > -c: < GAMES > -d: < HELP > - -Window Managers -a: X Window Snapshot -b: X Window Snapshot - -Applications -a: < SYSTEM > -b: < OFFICE > -c: < NETWORK > -d: < VIDEO > -e: < SCIENCE > -f: < SOUND > -g: < TERMINAL EMULATORS > -h: < VIEWERS > -i: < FILE MANAGEMENT > -j: < TEXT > -k: < GRAPHICS > -l: < EDITORS > -m: < DATA MANAGEMENT > -n: < PROGRAMMING > -o: < TOOLS > -p: < SHELLS > -q: < ACCESSIBILITY > - -System -a: < HARDWARE > -b: < ADMINISTRATION > -c: < MONITORING > -d: < PACKAGE MANAGEMENT > -e: < SECURITY > -f: < LANGUAGE ENVIRONMENT > -g: X Window Snapshot -h: X Window Snapshot - -Hardware -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot - -Administration -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot -h: X Window Snapshot -i: X Window Snapshot -j: X Window Snapshot -k: X Window Snapshot -l: X Window Snapshot -m: X Window Snapshot -n: X Window Snapshot -o: X Window Snapshot -p: X Window Snapshot -q: X Window Snapshot -r: X Window Snapshot -s: X Window Snapshot -t: X Window Snapshot -u: X Window Snapshot -v: X Window Snapshot -w: X Window Snapshot -x: X Window Snapshot -y: X Window Snapshot - -Monitoring -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot - -Package Management -a: X Window Snapshot -b: X Window Snapshot - -Security -a: X Window Snapshot - -Language Environment -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot -h: X Window Snapshot -i: X Window Snapshot -j: X Window Snapshot -k: X Window Snapshot -l: X Window Snapshot -m: X Window Snapshot -n: X Window Snapshot -o: X Window Snapshot -p: X Window Snapshot -q: X Window Snapshot -r: X Window Snapshot -s: X Window Snapshot - -Office -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot - -Network -a: < WEB BROWSING > -b: < COMMUNICATION > -c: < MONITORING > -d: < FILE TRANSFER > -e: < WEB NEWS > - -Web Browsing -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot - -Communication -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot - -Monitoring -a: X Window Snapshot - -File Transfer -a: X Window Snapshot -b: X Window Snapshot - -Web News -a: X Window Snapshot - -Video -a: X Window Snapshot -b: X Window Snapshot - -Science -a: < MATHEMATICS > - -Mathematics -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot - -Sound -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot -h: X Window Snapshot -i: X Window Snapshot -j: X Window Snapshot -k: X Window Snapshot -l: X Window Snapshot -m: X Window Snapshot -n: X Window Snapshot -o: X Window Snapshot -p: X Window Snapshot - -Terminal Emulators -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot - -Viewers -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot -h: X Window Snapshot -i: X Window Snapshot -j: X Window Snapshot - -File Management -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot - -Text -a: X Window Snapshot -b: X Window Snapshot - -Graphics -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot - -Editors -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot - -Data Management -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot - -Programming -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot - -Tools -a: X Window Snapshot - -Shells -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot - -Accessibility -a: X Window Snapshot - -Games -a: < ACTION > -b: < BOARD > -c: < CARD > -d: < PUZZLES > -e: < BLOCKS > -f: < TOYS > - -Action -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot - -Board -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot -g: X Window Snapshot - -Card -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot - -Puzzles -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot - -Blocks -a: X Window Snapshot -b: X Window Snapshot - -Toys -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot -e: X Window Snapshot -f: X Window Snapshot - -Help -a: X Window Snapshot -b: X Window Snapshot -c: X Window Snapshot -d: X Window Snapshot Child-Menu r: Rename the current child e: Ensure that all children names are unique n: Ensure that all children numbers are unique -x: Remove the current child from the CLFSWM tree -Delete: Remove the current child from its parent frame +Delete: Delete the current child and its children in all frames +X: Remove the current child from its parent frame h: Hide the current child u: Unhide a child in the current frame f: Unhide a child from all frames in the current frame @@ -514,6 +215,130 @@ i: Identify a key colon: Eval a lisp form from the query input exclam: Run a program from the query input +o: < Other window manager menu > + +Other-Window-Manager-Menu +x: Run xterm +t: Run twm +i: Run icewm +g: Run Gnome +k: Run KDE +c: Run XFCE +l: Run LXDE +p: Prompt for an other window manager + +Configuration-Menu +a: < Frame colors group > +b: < Miscellaneous group > +c: < Query string group > +d: < Menu group > +e: < Identify key group > +f: < Main mode group > +g: < Info mode group > +h: < Corner group > +i: < Hook group > +j: < Placement group > +k: < Circulate mode group > +l: < Second mode group > +F2: Save all configuration variables in clfswmrc + +Conf-Frame-Colors-Group +a: Configure FRAME-FOREGROUND-ROOT +b: Configure FRAME-FOREGROUND-HIDDEN +c: Configure FRAME-FOREGROUND +d: Configure FRAME-BACKGROUND + +Conf-Miscellaneous-Group +a: Configure CREATE-FRAME-ON-ROOT +b: Configure NEVER-MANAGED-WINDOW-LIST +c: Configure DEFAULT-FONT-STRING +d: Configure DEFAULT-MODIFIERS +e: Configure DEFAULT-FOCUS-POLICY +f: Configure DEFAULT-FRAME-DATA +g: Configure LOOP-TIMEOUT +h: Configure HAVE-TO-COMPRESS-NOTIFY +i: Configure DEFAULT-WINDOW-WIDTH +j: Configure DEFAULT-MANAGED-TYPE +k: Configure DEFAULT-WINDOW-HEIGHT + +Conf-Query-String-Group +a: Configure QUERY-BACKGROUND +b: Configure QUERY-BORDER +c: Configure QUERY-FONT-STRING +d: Configure QUERY-FOREGROUND + +Conf-Menu-Group +a: Configure MENU-COLOR-SUBMENU +b: Configure MENU-COLOR-COMMENT +c: Configure MENU-COLOR-MENU-KEY +d: Configure MENU-COLOR-KEY + +Conf-Identify-Key-Group +a: Configure IDENTIFY-FOREGROUND +b: Configure IDENTIFY-BORDER +c: Configure IDENTIFY-BACKGROUND +d: Configure IDENTIFY-FONT-STRING + +Conf-Main-Mode-Group +a: Configure COLOR-MAYBE-SELECTED +b: Configure COLOR-SELECTED +c: Configure COLOR-UNSELECTED + +Conf-Info-Mode-Group +a: Configure INFO-BACKGROUND +b: Configure INFO-FOREGROUND +c: Configure INFO-BORDER +d: Configure INFO-SELECTED-BACKGROUND +e: Configure INFO-FONT-STRING +f: Configure INFO-COLOR-UNDERLINE +g: Configure INFO-COLOR-FIRST +h: Configure INFO-LINE-CURSOR +i: Configure INFO-COLOR-TITLE +j: Configure INFO-CLICK-TO-SELECT +k: Configure INFO-COLOR-SECOND + +Conf-Corner-Group +a: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON +b: Configure CORNER-MAIN-MODE-LEFT-BUTTON +c: Configure VIRTUAL-KEYBOARD-KILL-CMD +d: Configure CLFSWM-TERMINAL-CMD +e: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON +f: Configure VIRTUAL-KEYBOARD-CMD +g: Configure CORNER-SECOND-MODE-LEFT-BUTTON +h: Configure CORNER-SIZE +i: Configure CORNER-MAIN-MODE-RIGHT-BUTTON +j: Configure CLFSWM-TERMINAL-NAME +k: Configure CORNER-SECOND-MODE-RIGHT-BUTTON + +Conf-Hook-Group +a: Configure INIT-HOOK +b: Configure LOOP-HOOK +c: Configure BINDING-HOOK +d: Configure DEFAULT-NW-HOOK + +Conf-Placement-Group +a: Configure BANISH-POINTER-PLACEMENT +b: Configure SECOND-MODE-PLACEMENT +c: Configure QUERY-MODE-PLACEMENT +d: Configure INFO-MODE-PLACEMENT +e: Configure CIRCULATE-MODE-PLACEMENT + +Conf-Circulate-Mode-Group +a: Configure CIRCULATE-WIDTH +b: Configure CIRCULATE-HEIGHT +c: Configure CIRCULATE-FONT-STRING +d: Configure CIRCULATE-FOREGROUND +e: Configure CIRCULATE-TEXT-LIMITE +f: Configure CIRCULATE-BACKGROUND +g: Configure CIRCULATE-BORDER + +Conf-Second-Mode-Group +a: Configure SM-FONT-STRING +b: Configure SM-BACKGROUND-COLOR +c: Configure SM-FOREGROUND-COLOR +d: Configure SM-HEIGHT +e: Configure SM-BORDER-COLOR +f: Configure SM-WIDTH Clfswm-Menu r: Reset clfswm Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Mon Aug 16 17:50:24 2010 @@ -59,9 +59,9 @@ #-BUILD (ignore-errors - (main :read-conf-file-p t)) + (main :read-conf-file-p nil)) -;;(produce-all-docs) +(produce-all-docs) ;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest From pbrochard at common-lisp.net Mon Aug 16 21:50:43 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 16 Aug 2010 17:50:43 -0400 Subject: [clfswm-cvs] r292 - clfswm Message-ID: Author: pbrochard Date: Mon Aug 16 17:50:43 2010 New Revision: 292 Log: Documentation update Modified: clfswm/load.lisp Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Mon Aug 16 17:50:43 2010 @@ -59,9 +59,9 @@ #-BUILD (ignore-errors - (main :read-conf-file-p nil)) + (main :read-conf-file-p t)) -(produce-all-docs) +;;(produce-all-docs) ;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest From pbrochard at common-lisp.net Mon Aug 16 22:34:09 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 16 Aug 2010 18:34:09 -0400 Subject: [clfswm-cvs] r293 - in clfswm: . src Message-ID: Author: pbrochard Date: Mon Aug 16 18:34:09 2010 New Revision: 293 Log: src/clfswm-util.lisp (mouse-click-to-focus-generic): Fix an unwanted flickering with unmanaged windows. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Aug 16 18:34:09 2010 @@ -1,3 +1,8 @@ +2010-08-17 Philippe Brochard + + * src/clfswm-util.lisp (mouse-click-to-focus-generic): Fix an + unwanted flickering with unmanaged windows. + 2010-08-16 Philippe Brochard * src/package.lisp: Remove event handler hooks as they're not Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Mon Aug 16 18:34:09 2010 @@ -7,7 +7,10 @@ =============== Should handle these soon. -Nothing here :) +BUGS: - Unwanted flickering with unmanaged windows. + - Focus with multiple copy of the same window fall in the wrong frame. + +######Nothing here :) MAYBE ===== Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Mon Aug 16 18:34:09 2010 @@ -569,13 +569,11 @@ (unless (equal (type-of child) 'frame) (setf child (find-frame-window child *current-root*))) (setf parent (find-parent-frame child))))) - (when (and child parent) - (focus-all-children child parent) - (show-all-children)) (when (equal (type-of child) 'frame) (funcall mouse-fn child parent root-x root-y)) - (when (show-all-children *current-root*) - (setf to-replay nil))) + (when (and child parent (focus-all-children child parent)) + (when (show-all-children *current-root*) + (setf to-replay nil)))) (if to-replay (replay-button-event) (stop-button-event))))) From pbrochard at common-lisp.net Mon Aug 16 22:34:55 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 16 Aug 2010 18:34:55 -0400 Subject: [clfswm-cvs] r294 - clfswm Message-ID: Author: pbrochard Date: Mon Aug 16 18:34:55 2010 New Revision: 294 Log: TODO update Modified: clfswm/TODO Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Mon Aug 16 18:34:55 2010 @@ -7,8 +7,7 @@ =============== Should handle these soon. -BUGS: - Unwanted flickering with unmanaged windows. - - Focus with multiple copy of the same window fall in the wrong frame. +BUGS: - Focus with multiple copy of the same window fall in the wrong frame. ######Nothing here :) From pbrochard at common-lisp.net Tue Aug 17 12:38:44 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 17 Aug 2010 08:38:44 -0400 Subject: [clfswm-cvs] r295 - in clfswm: . src Message-ID: Author: pbrochard Date: Tue Aug 17 08:38:42 2010 New Revision: 295 Log: src/clfswm-internal.lisp. with-find-in-all-frames: New macro. find-parent-frame, find-frame-window, find-frame-by-name find-frame-by-number: Use with-find-in-all-frames to search in frames in the right order. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Aug 17 08:38:42 2010 @@ -1,5 +1,10 @@ 2010-08-17 Philippe Brochard + * src/clfswm-internal.lisp (with-find-in-all-frames): New macro. + (find-parent-frame, find-frame-window, find-frame-by-name) + (find-frame-by-number): Use with-find-in-all-frames to search in + frames in the right order. + * src/clfswm-util.lisp (mouse-click-to-focus-generic): Fix an unwanted flickering with unmanaged windows. Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Tue Aug 17 08:38:42 2010 @@ -7,9 +7,7 @@ =============== Should handle these soon. -BUGS: - Focus with multiple copy of the same window fall in the wrong frame. - -######Nothing here :) +Nothing here :) MAYBE ===== Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Tue Aug 17 08:38:42 2010 @@ -316,7 +316,6 @@ - (defun find-child (to-find root) "Find to-find in root or in its children" (with-all-children (root child) @@ -325,34 +324,37 @@ -(defun find-parent-frame (to-find &optional (root *root-frame*)) - "Return the parent frame of to-find" - (with-all-frames (root frame) - (when (member to-find (frame-child frame)) - (return-from find-parent-frame frame)))) - +(defmacro with-find-in-all-frames (test &optional return-value) + `(let (ret) + (block return-block + (with-all-frames (root frame) + (when ,test + (if first-foundp + (return-from return-block (or ,return-value frame)) + (setf ret frame)))) + (or ,return-value ret)))) +(defun find-parent-frame (to-find &optional (root *root-frame*) first-foundp) + "Return the parent frame of to-find" + (with-find-in-all-frames + (member to-find (frame-child frame)))) -(defun find-frame-window (window &optional (root *root-frame*)) +(defun find-frame-window (window &optional (root *root-frame*) first-foundp) "Return the frame with the window window" - (with-all-frames (root frame) - (when (xlib:window-equal window (frame-window frame)) - (return-from find-frame-window frame)))) - + (with-find-in-all-frames + (xlib:window-equal window (frame-window frame)))) -(defun find-frame-by-name (name) +(defun find-frame-by-name (name &optional (root *root-frame*) first-foundp) "Find a frame from its name" (when name - (with-all-frames (*root-frame* frame) - (when (string-equal name (frame-name frame)) - (return-from find-frame-by-name frame))))) + (with-find-in-all-frames + (string-equal name (frame-name frame))))) -(defun find-frame-by-number (number) +(defun find-frame-by-number (number &optional (root *root-frame*) first-foundp) "Find a frame from its number" (when (numberp number) - (with-all-frames (*root-frame* frame) - (when (= number (frame-number frame)) - (return-from find-frame-by-number frame))))) + (with-find-in-all-frames + (= number (frame-number frame))))) (defun find-child-in-parent (child base) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Tue Aug 17 08:38:42 2010 @@ -159,7 +159,7 @@ win))) -(defun find-child-under-mouse (x y) +(defun find-child-under-mouse (x y &optional first-foundp) "Return the child under the mouse" (with-xlib-protect (let ((ret nil)) @@ -167,10 +167,14 @@ (when (and (or (managed-window-p child parent) (equal parent *current-child*)) (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) - (setf ret child)) + (if first-foundp + (return-from find-child-under-mouse child) + (setf ret child))) (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child))) (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child)))) - (setf ret child))) + (if first-foundp + (return-from find-child-under-mouse child) + (setf ret child)))) ret))) From pbrochard at common-lisp.net Tue Aug 17 21:14:53 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 17 Aug 2010 17:14:53 -0400 Subject: [clfswm-cvs] r296 - in clfswm: . contrib/server src Message-ID: Author: pbrochard Date: Tue Aug 17 17:14:53 2010 New Revision: 296 Log: src/xlib-util.lisp (compress-motion-notify): Use a loop instead of an event-case. Modified: clfswm/ChangeLog clfswm/contrib/server/server.lisp clfswm/load.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Aug 17 17:14:53 2010 @@ -1,5 +1,8 @@ 2010-08-17 Philippe Brochard + * src/xlib-util.lisp (compress-motion-notify): Use a loop instead + of an event-case. + * src/clfswm-internal.lisp (with-find-in-all-frames): New macro. (find-parent-frame, find-frame-window, find-frame-by-name) (find-frame-by-number): Use with-find-in-all-frames to search in Modified: clfswm/contrib/server/server.lisp ============================================================================== --- clfswm/contrib/server/server.lisp (original) +++ clfswm/contrib/server/server.lisp Tue Aug 17 17:14:53 2010 @@ -48,6 +48,7 @@ (defparameter *server-socket* nil) (defparameter *server-port* 33333) (defparameter *server-allowed-host* '("127.0.0.1")) +(defparameter *server-wait-timeout* 0.001d0) (defparameter *server-connection* nil) @@ -130,7 +131,7 @@ (defun server-handle-new-connection () (handler-case - (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait 0.01d0)))) + (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait *server-wait-timeout*)))) (when stream (if (server-is-allowed-host stream) (multiple-value-bind (local-host local-port remote-host remote-port) Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Tue Aug 17 17:14:53 2010 @@ -29,16 +29,13 @@ #+CMU (setf ext:*gc-verbose* nil) -#+CMU -(require :clx) - #+SBCL (require :asdf) #+SBCL (require :sb-posix) -#+(or SBCL ECL) +#+(or CMU SBCL ECL) (require :clx) #-ASDF Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Tue Aug 17 17:14:53 2010 @@ -70,7 +70,7 @@ , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) (declare (ignore c))))) -;;(dbg c ',body)))) + ;;(dbg c ',body)))) @@ -757,8 +757,8 @@ (defun compress-motion-notify () (when *have-to-compress-notify* - (xlib:event-case (*display* :discard-p nil :peek-p t :timeout 0) - (:motion-notify () t)))) + (loop while (xlib:event-cond (*display* :timeout 0) + (:motion-notify () t))))) (defun display-all-cursors (&optional (display-time 1)) From pbrochard at common-lisp.net Tue Aug 17 21:27:19 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 17 Aug 2010 17:27:19 -0400 Subject: [clfswm-cvs] r297 - in clfswm: . contrib/server Message-ID: Author: pbrochard Date: Tue Aug 17 17:27:18 2010 New Revision: 297 Log: contrib/server/key.lisp (ushell-sh): Add ccl and ecl support. Modified: clfswm/ChangeLog clfswm/contrib/server/key.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Aug 17 17:27:18 2010 @@ -1,5 +1,7 @@ 2010-08-17 Philippe Brochard + * contrib/server/key.lisp (ushell-sh): Add ccl and ecl support. + * src/xlib-util.lisp (compress-motion-notify): Use a loop instead of an event-case. Modified: clfswm/contrib/server/key.lisp ============================================================================== --- clfswm/contrib/server/key.lisp (original) +++ clfswm/contrib/server/key.lisp Tue Aug 17 17:27:18 2010 @@ -12,6 +12,8 @@ (defparameter *final-key-perms* "0400") + + (defun ushell-sh (formatter &rest args) (labels ((remove-plist (plist &rest keys) "Remove the keys from the plist. @@ -43,8 +45,10 @@ opts) #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts) #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts) - #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl) - (error 'not-implemented :proc (list 'run-prog prog opts)))) + #+ecl (apply #'ext:run-program prog args opts) + #+ccl (apply #'ccl:run-program prog args opts) + #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ccl ecl) + (error "Error: urun-prog not implemented"))) (urun-prog "/bin/sh" :args (list "-c" (apply #'format nil formatter args))))) From pbrochard at common-lisp.net Wed Aug 25 19:44:19 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 25 Aug 2010 15:44:19 -0400 Subject: [clfswm-cvs] r298 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Aug 25 15:44:18 2010 New Revision: 298 Log: main-loop, generic-mode: Use an xlib:event-listen before processing event with xlib:process-event. This prevent a bug with CLX threaded implementation like sbcl. Modified: clfswm/ChangeLog clfswm/src/clfswm-generic-mode.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-query.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/package.lisp clfswm/src/tools.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Aug 25 15:44:18 2010 @@ -1,3 +1,14 @@ +2010-08-25 Philippe Brochard + + * src/clfswm-generic-mode.lisp (generic-mode): Use an + xlib:event-listen before processing event with + xlib:process-event. This prevent a bug with CLX threaded + implementation like sbcl. + + * src/clfswm.lisp (main-loop): Use an xlib:event-listen before + processing event with xlib:process-event. This prevent a bug with + CLX threaded implementation like sbcl. + 2010-08-17 Philippe Brochard * contrib/server/key.lisp (ushell-sh): Add ccl and ecl support. Modified: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- clfswm/src/clfswm-generic-mode.lisp (original) +++ clfswm/src/clfswm-generic-mode.lisp Wed Aug 25 15:44:18 2010 @@ -36,14 +36,16 @@ (assoc-keyword-handle-event add-mode))) (assoc-keyword-handle-event mode) (nfuncall enter-function) - (unwind-protect - (catch exit-tag + (catch exit-tag + (unwind-protect (loop (call-hook loop-hook) (nfuncall loop-function) (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*) - (xlib:display-finish-output *display*))) - (nfuncall leave-function) - (unassoc-keyword-handle-event) - (assoc-keyword-handle-event last-mode)))) + (when (xlib:event-listen *display* *loop-timeout*) + (xlib:process-event *display* :handler #'handle-event)) + (xlib:display-finish-output *display*)) + (nfuncall leave-function) + (unassoc-keyword-handle-event) + (assoc-keyword-handle-event last-mode))))) + Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Wed Aug 25 15:44:18 2010 @@ -345,9 +345,9 @@ (xgrab-keyboard *root*)) (wait-no-key-or-button-press) (generic-mode 'info-mode 'exit-info-loop - :loop-function (lambda () - (raise-window (info-window info))) - :original-mode '(main-mode)) + :loop-function (lambda () + (raise-window (info-window info))) + :original-mode '(main-mode)) (if pointer-grabbed-p (xgrab-pointer *root* 66 67) (xungrab-pointer)) @@ -356,6 +356,7 @@ (xlib:free-gcontext gc) (xlib:destroy-window window) (xlib:close-font font) + (xlib:display-finish-output *display*) (display-all-frame-info) (wait-no-key-or-button-press) *info-selected-item*))))))) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Wed Aug 25 15:44:18 2010 @@ -78,6 +78,7 @@ (setf *query-return* return) (throw 'exit-query-loop nil)) + (defun leave-query-mode-valid () (leave-query-mode :Return)) @@ -130,6 +131,7 @@ (wait-no-key-or-button-press)))) + (defun query-leave-function () (xlib:destroy-window *query-window*) (xlib:close-font *query-font*) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Wed Aug 25 15:44:18 2010 @@ -320,7 +320,8 @@ (unwind-protect (loop until done do (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-identify :timeout *loop-timeout*)) + (when (xlib:event-listen *display* *loop-timeout*) + (xlib:process-event *display* :handler #'handle-identify))) (xlib:destroy-window window) (xlib:close-font font) (xgrab-pointer *root* 66 67))))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Wed Aug 25 15:44:18 2010 @@ -122,9 +122,10 @@ (defun main-loop () (loop (with-xlib-protect - (call-hook *loop-hook*) + (call-hook *loop-hook*) (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*)))) + (when (xlib:event-listen *display* *loop-timeout*) + (xlib:process-event *display* :handler #'handle-event))))) ;;(dbg "Main loop finish" c))))) @@ -238,15 +239,15 @@ (exit-clfswm))) (when error-msg (info-mode error-msg)) - (unwind-protect - (catch 'exit-main-loop - (main-loop)) - (ungrab-main-keys) - (xlib:destroy-window *no-focus-window*) - (xlib:free-pixmap *pixmap-buffer*) - (xlib:close-display *display*) - #+:event-debug - (format t "~2&Unhandled events: ~A~%" *unhandled-events*))) + (catch 'exit-main-loop + (unwind-protect + (main-loop) + (ungrab-main-keys) + (xlib:destroy-window *no-focus-window*) + (xlib:free-pixmap *pixmap-buffer*) + (xlib:close-display *display*) + #+:event-debug + (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))) (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Wed Aug 25 15:44:18 2010 @@ -27,7 +27,7 @@ (defpackage clfswm (:use :common-lisp :my-html :tools :version) - ;;(:shadow :defun) +;; (:shadow :defun) (:export :main :reload-clfswm :reset-clfswm @@ -214,7 +214,7 @@ ;; For debug - redefine defun ;;(shadow :defun) -;; + ;;(defmacro defun (name args &body body) ;; `(progn ;; (format t "defun: ~A ~A~%" ',name ',args) @@ -228,3 +228,5 @@ ;; (format t "Root tree=~A~%All windows=~A~%" ;; (xlib:query-tree *root*) (get-all-windows)) ;; (force-output)))))) + + Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Wed Aug 25 15:44:18 2010 @@ -40,6 +40,7 @@ :remove-hook :dbg :dbgnl + :dbgc :with-all-internal-symbols :export-all-functions :export-all-variables :export-all-functions-and-variables @@ -209,7 +210,11 @@ , at forms)) - +(defun dbgc (obj &optional newline) + (princ obj) + (when newline + (terpri)) + (force-output)) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Wed Aug 25 15:44:18 2010 @@ -69,7 +69,8 @@ (progn , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) - (declare (ignore c))))) + (dbg c)))) + ;;(declare (ignore c))))) ;;(dbg c ',body)))) @@ -117,7 +118,9 @@ (let ((keyword (handle-event->keyword symbol))) (when (fboundp symbol) #+:event-debug - (format t "~&Associating: ~S with ~S~%" symbol keyword) + (progn + (format t "~&Associating: ~S with ~S~%" symbol keyword) + (force-output)) (setf (symbol-function keyword) (symbol-function symbol)))))) (defun unassoc-keyword-handle-event (&optional (mode "")) @@ -127,7 +130,9 @@ (let ((keyword (handle-event->keyword symbol))) (when (fboundp keyword) #+:event-debug - (format t "~&Unassociating: ~S ~S~%" symbol keyword) + (progn + (format t "~&Unassociating: ~S ~S~%" symbol keyword) + (force-output)) (fmakunbound keyword))))) (defmacro define-handler (mode keyword args &body body) @@ -431,7 +436,8 @@ &optional (pointer-mask '(:enter-window :pointer-motion :button-press :button-release)) owner-p) "Grab the pointer and set the pointer shape." - (free-grab-pointer) + (when pointer-grabbed + (xungrab-pointer)) (setf pointer-grabbed t) (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))) @@ -444,10 +450,10 @@ :foreground black :background white)) (xlib:grab-pointer root pointer-mask - :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil :cursor cursor)) + :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil :cursor cursor)) (t (xlib:grab-pointer root pointer-mask - :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil))))) + :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil))))) (defun xungrab-pointer () "Remove the grab on the cursor and restore the cursor shape." @@ -698,12 +704,14 @@ (xgrab-pointer *root* ,cursor ,mask) (unless keyboard-grabbed (xgrab-keyboard *root*)) - , at body - (if pointer-grabbed - (xgrab-pointer *root* ,old-cursor ,old-mask) - (xungrab-pointer)) - (unless keyboard-grabbed - (xungrab-keyboard)))) + (unwind-protect + (progn + , at body) + (if pointer-grabbed + (xgrab-pointer *root* ,old-cursor ,old-mask) + (xungrab-pointer)) + (unless keyboard-grabbed + (xungrab-keyboard))))) @@ -727,7 +735,8 @@ (loop (let ((key (loop for k across (xlib:query-keymap *display*) for code from 0 - when (and (plusp k) (not (modifier-p code))) return t)) + when (and (plusp k) (not (modifier-p code))) + return t)) (button (loop for b in (xlib:make-state-keys (nth-value 4 (xlib:query-pointer *root*))) when (member b '(:button-1 :button-2 :button-3 :button-4 :button-5)) return t))) From pbrochard at common-lisp.net Thu Aug 26 11:43:46 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 26 Aug 2010 07:43:46 -0400 Subject: [clfswm-cvs] r299 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Aug 26 07:43:46 2010 New Revision: 299 Log: * src/*.lisp: Use the new child-equal-p to compare children. This prevent a bug with sbcl/cmucl when the standard equal function does not work with xlib:window. * src/clfswm-internal.lisp (child-equal-p): New predicate. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-corner.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-layout.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Aug 26 07:43:46 2010 @@ -1,3 +1,11 @@ +2010-08-26 Philippe Brochard + + * src/*.lisp: Use the new child-equal-p to compare children. This + prevent a bug with sbcl/cmucl when the standard equal function + does not work with xlib:window. + + * src/clfswm-internal.lisp (child-equal-p): New predicate. + 2010-08-25 Philippe Brochard * src/clfswm-generic-mode.lisp (generic-mode): Use an Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Thu Aug 26 07:43:46 2010 @@ -85,8 +85,8 @@ (defun reorder-brother (direction) (no-focus) - (let ((frame-is-root? (and (equal *current-root* *current-child*) - (not (equal *current-root* *root-frame*))))) + (let ((frame-is-root? (and (child-equal-p *current-root* *current-child*) + (not (child-equal-p *current-root* *root-frame*))))) (if frame-is-root? (hide-all *current-root*) (select-current-frame nil)) Modified: clfswm/src/clfswm-corner.lisp ============================================================================== --- clfswm/src/clfswm-corner.lisp (original) +++ clfswm/src/clfswm-corner.lisp Thu Aug 26 07:43:46 2010 @@ -128,7 +128,7 @@ (dolist (win (xlib:query-tree *root*)) (when (string-equal (xlib:wm-name win) *clfswm-terminal-name*) (setf found t) - (unless (equal *clfswm-terminal* win) + (unless (child-equal-p *clfswm-terminal* win) (setf *clfswm-terminal* win) (hide-window *clfswm-terminal*)))) (unless found Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Thu Aug 26 07:43:46 2010 @@ -127,6 +127,19 @@ +(defgeneric child-equal-p (child-1 child-2)) + +(defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window)) + (xlib:window-equal child-1 child-2)) + +(defmethod child-equal-p ((child-1 frame) (child-2 frame)) + (equal child-1 child-2)) + +(defmethod child-equal-p (child-1 child-2) + (declare (ignore child-1 child-2)) + nil) + + (defgeneric child-name (child)) @@ -319,7 +332,7 @@ (defun find-child (to-find root) "Find to-find in root or in its children" (with-all-children (root child) - (when (equal child to-find) + (when (child-equal-p child to-find) (return-from find-child t)))) @@ -360,7 +373,7 @@ (defun find-child-in-parent (child base) "Return t if child is in base or in its parents" (labels ((rec (base) - (when (equal child base) + (when (child-equal-p child base) (return-from find-child-in-parent t)) (let ((parent (find-parent-frame base))) (when parent @@ -409,15 +422,15 @@ (setf (xlib:gcontext-background gc) (get-color *frame-background*) (xlib:window-background window) (get-color *frame-background*)) (clear-pixmap-buffer window gc) - (setf (xlib:gcontext-foreground gc) (get-color (if (and (equal frame *current-root*) - (equal frame *current-child*)) + (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-equal-p frame *current-root*) + (child-equal-p frame *current-child*)) *frame-foreground-root* *frame-foreground*))) (xlib:draw-glyphs *pixmap-buffer* gc 5 dy (format nil "Frame: ~A~A" number (if name (format nil " - ~A" name) ""))) (let ((pos dy)) - (when (equal frame *current-root*) + (when (child-equal-p frame *current-root*) (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) (format nil "~A hidden windows" (length (get-hidden-windows)))) (when *child-selection* @@ -508,7 +521,7 @@ (with-xlib-protect (with-slots (window show-window-p) frame (if show-window-p - (when (or *show-root-frame-p* (not (equal frame *current-root*))) + (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*))) (setf (xlib:window-background window) (get-color "Black")) (map-window window) (when raise-p (raise-window window))) @@ -519,7 +532,7 @@ (defmethod show-child ((window xlib:window) parent raise-p) (with-xlib-protect (if (or (managed-window-p window parent) - (equal parent *current-child*)) + (child-equal-p parent *current-child*)) (progn (map-window window) (when raise-p (raise-window window))) @@ -636,13 +649,13 @@ (labels ((rec-geom (root parent selected-p selected-parent-p) (when (adapt-child-to-parent root parent) (setf geometry-change t)) - (select-child root (cond ((equal root *current-child*) t) + (select-child root (cond ((child-equal-p root *current-child*) t) ((and selected-p selected-parent-p) :maybe) (t nil))) (when (frame-p root) (let ((selected-child (frame-selected-child root))) (dolist (child (reverse (frame-child root))) - (rec-geom child root (equal child selected-child) (and selected-p selected-parent-p)))))) + (rec-geom child root (child-equal-p child selected-child) (and selected-p selected-parent-p)))))) (rec (root parent raise-p) (show-child root parent raise-p) (when (frame-p root) @@ -676,7 +689,7 @@ "Focus child - Return true if something has change" (when (and (frame-p parent) (member child (frame-child parent))) - (when (not (equal child (frame-selected-child parent))) + (when (not (child-equal-p child (frame-selected-child parent))) (with-slots ((parent-child child) selected-pos) parent (setf parent-child (nth-insert selected-pos child (remove child parent-child)))) t))) @@ -694,7 +707,7 @@ (defun set-current-child-generic (child) - (unless (equal *current-child* child) + (unless (child-equal-p *current-child* child) (setf *current-child* child) t)) @@ -739,7 +752,7 @@ (defun select-previous-level () "Select the previous level in frame" - (unless (equal *current-child* *current-root*) + (unless (child-equal-p *current-child* *current-root*) (select-current-frame :maybe) (awhen (find-parent-frame *current-child*) (setf *current-child* it)) @@ -817,7 +830,7 @@ (defun remove-child-in-frame (child frame) "Remove the child in frame" (when (frame-p frame) - (setf (frame-child frame) (remove child (frame-child frame) :test #'equal)))) + (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p)))) (defun remove-child-in-frames (child root) "Remove child in the frame root and in all its children" @@ -827,9 +840,9 @@ (defun remove-child-in-all-frames (child) "Remove child in all frames from *root-frame*" - (when (equal child *current-root*) + (when (child-equal-p child *current-root*) (setf *current-root* (find-parent-frame child))) - (when (equal child *current-child*) + (when (child-equal-p child *current-child*) (setf *current-child* *current-root*)) (remove-child-in-frames child *root-frame*)) @@ -848,9 +861,9 @@ (defun delete-child-in-all-frames (child) "Delete child in all frames from *root-frame*" - (when (equal child *current-root*) + (when (child-equal-p child *current-root*) (setf *current-root* (find-parent-frame child))) - (when (equal child *current-child*) + (when (child-equal-p child *current-child*) (setf *current-child* *current-root*)) (delete-child-in-frames child *root-frame*)) @@ -867,9 +880,9 @@ (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window)) "Delete child and its children in all frames from *root-frame*" - (when (equal child *current-root*) + (when (child-equal-p child *current-root*) (setf *current-root* (find-parent-frame child))) - (when (equal child *current-child*) + (when (child-equal-p child *current-child*) (setf *current-child* *current-root*)) (delete-child-and-children-in-frames child *root-frame* close-methode)) Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Thu Aug 26 07:43:46 2010 @@ -198,7 +198,7 @@ (unless (member ch managed-children) (setf managed-children (append managed-children (list child))))) (setf managed-children (remove-if-not (lambda (x) - (member x managed-in-parent :test #'equal)) + (member x managed-in-parent :test #'child-equal-p)) managed-children)) (setf (frame-data-slot parent :layout-managed-children) managed-children) managed-children)) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Thu Aug 26 07:43:46 2010 @@ -108,7 +108,7 @@ (defun delete-focus-window-generic (close-fun) (let ((window (xlib:input-focus *display*))) (when (and window (not (xlib:window-equal window *no-focus-window*))) - (when (equal window *current-child*) + (when (child-equal-p window *current-child*) (setf *current-child* *current-root*)) (hide-child window) (delete-child-and-children-in-all-frames window close-fun) @@ -149,7 +149,7 @@ (with-xlib-protect (let ((win *root*)) (with-all-windows-frames-and-parent (*current-root* child parent) - (when (and (or (managed-window-p child parent) (equal parent *current-child*)) + (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) (setf win child)) @@ -164,7 +164,7 @@ (with-xlib-protect (let ((ret nil)) (with-all-windows-frames-and-parent (*current-root* child parent) - (when (and (or (managed-window-p child parent) (equal parent *current-child*)) + (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child))) (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child)))) (if first-foundp @@ -433,10 +433,10 @@ ;;; Delete by functions (defun delete-frame-by (frame) (hide-all *current-root*) - (unless (equal frame *root-frame*) - (when (equal frame *current-root*) + (unless (child-equal-p frame *root-frame*) + (when (child-equal-p frame *current-root*) (setf *current-root* *root-frame*)) - (when (equal frame *current-child*) + (when (child-equal-p frame *current-child*) (setf *current-child* *current-root*)) (remove-child-in-frame frame (find-parent-frame frame))) (show-all-children *current-root*)) @@ -556,9 +556,9 @@ (let* ((to-replay t) (child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child)) - (root-p (or (equal window *root*) + (root-p (or (child-equal-p window *root*) (and (frame-p *current-root*) - (equal child (frame-window *current-root*)))))) + (child-equal-p child (frame-window *current-root*)))))) (labels ((add-new-frame () (setf child (create-frame) parent *current-root* @@ -612,7 +612,7 @@ For window: set current child to window or its parent according to window-parent" (let* ((child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child))) - (when (and (equal child *current-root*) + (when (and (child-equal-p child *current-root*) (frame-p *current-root*)) (setf child (create-frame) parent *current-root* @@ -993,7 +993,7 @@ "Move the child under the mouse cursor to another frame" (declare (ignore window)) (let ((child (find-child-under-mouse root-x root-y))) - (unless (equal child *current-root*) + (unless (child-equal-p child *current-root*) (hide-all child) (remove-child-in-frame child (find-parent-frame child)) (wait-mouse-button-release 50 51) @@ -1002,7 +1002,7 @@ (let ((dest (find-child-under-mouse x y))) (when (xlib:window-p dest) (setf dest (find-parent-frame dest))) - (unless (equal child dest) + (unless (child-equal-p child dest) (move-child-to child dest) (show-all-children *current-root*)))))) (stop-button-event)) @@ -1190,7 +1190,7 @@ (when name1 (let ((acc nil)) (with-all-children (*root-frame* c) - (unless (equal child c)) + (unless (child-equal-p child c)) (multiple-value-bind (num2 name2) (extract-number-from-name (child-name c)) (when (string-equal name1 name2) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Thu Aug 26 07:43:46 2010 @@ -87,6 +87,7 @@ (delete-child-in-all-frames window) (show-all-children)))) + (define-handler main-mode :destroy-notify (send-event-p event-window window) (unless (or send-event-p (xlib:window-equal window event-window)) @@ -106,7 +107,7 @@ (focus-window window))) (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child))) - (unless (or (equal child *current-root*) + (unless (or (child-equal-p child *current-root*) (equal (typecase child (xlib:window parent) (t child)) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Thu Aug 26 07:43:46 2010 @@ -69,10 +69,18 @@ (progn , at body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) - (dbg c)))) + ;;(dbg c)))) ;;(declare (ignore c))))) + (format t "~&Xlib-error: ~A~%Body:~%~A~%" c ',body) + (force-output)))) ;;(dbg c ',body)))) +;;(defmacro with-xlib-protect (&body body) +;; "Prevent Xlib errors" +;; `(progn +;; , at body)) + + @@ -147,9 +155,9 @@ (defun handle-event (&rest event-slots &key event-key &allow-other-keys) (with-xlib-protect - (if (fboundp event-key) - (apply event-key event-slots) - #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) + (if (fboundp event-key) + (apply event-key event-slots) + #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) t) @@ -787,7 +795,7 @@ (xlib:draw-rectangle *pixmap-buffer* gc 0 0 (xlib:drawable-width window) (xlib:drawable-height window) t) - (rotatef (xlib:gcontext-foreground gc) (xlib:gcontext-background gc))) + (rotatef (xlib:gcontext-foreground gc) (xlib:gcontext-background gc))) (defun copy-pixmap-buffer (window gc) (xlib:copy-area *pixmap-buffer* gc From pbrochard at common-lisp.net Thu Aug 26 19:24:52 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 26 Aug 2010 15:24:52 -0400 Subject: [clfswm-cvs] r300 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Aug 26 15:24:52 2010 New Revision: 300 Log: src/clfswm-keys.lisp (define-ungrab/grab): Use all values returned by xlib:keysym->keycodes. Modified: clfswm/ChangeLog clfswm/src/bindings.lisp clfswm/src/clfswm-keys.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Aug 26 15:24:52 2010 @@ -1,5 +1,8 @@ 2010-08-26 Philippe Brochard + * src/clfswm-keys.lisp (define-ungrab/grab): Use all values + returned by xlib:keysym->keycodes. + * src/*.lisp: Use the new child-equal-p to compare children. This prevent a bug with sbcl/cmucl when the standard equal function does not work with xlib:window. Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Thu Aug 26 15:24:52 2010 @@ -68,6 +68,10 @@ ;; Second mode (define-main-key (#\t :mod-1) 'second-key-mode) (define-main-key ("less" :control) 'second-key-mode) + (define-main-key ("Z" :control) 'second-key-mode) + ;;(define-main-key (#\< :control) 'second-key-mode) + ;;(define-main-key (#x003c :control) 'second-key-mode) + ;;(define-main-key (94 :control) 'second-key-mode) ;; Bind or jump functions (define-main-key ("1" :mod-1) 'bind-or-jump 1) (define-main-key ("2" :mod-1) 'bind-or-jump 2) Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Thu Aug 26 15:24:52 2010 @@ -144,15 +144,23 @@ (let* ((key (first k)) (modifiers (second k)) (keycode (typecase key - (character (char->keycode key)) + (character (multiple-value-list (char->keycode key))) (number key) (string (let* ((keysym (keysym-name->keysym key)) - (ret-keycode (xlib:keysym->keycodes *display* keysym))) - (when (/= keysym (xlib:keycode->keysym *display* ret-keycode 0)) - (setf modifiers (add-in-state modifiers :shift))) + (ret-keycode (multiple-value-list (xlib:keysym->keycodes *display* keysym)))) + (let ((found nil)) + (dolist (kc ret-keycode) + (when (= keysym (xlib:keycode->keysym *display* kc 0)) + (setf found t))) + (unless found + (setf modifiers (add-in-state modifiers :shift)))) ret-keycode))))) + (dbg key modifiers keycode) (if keycode - (,function *root* keycode :modifiers modifiers) + (if (consp keycode) + (dolist (kc (remove-duplicates keycode)) + (,function *root* kc :modifiers modifiers)) + (,function *root* keycode :modifiers modifiers)) (format t "~&Grabbing error: Can't find key '~A'~%" key))) (error (c) ;;(declare (ignore c)) From pbrochard at common-lisp.net Thu Aug 26 19:26:11 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 26 Aug 2010 15:26:11 -0400 Subject: [clfswm-cvs] r301 - clfswm/src Message-ID: Author: pbrochard Date: Thu Aug 26 15:26:11 2010 New Revision: 301 Log: src/clfswm-keys.lisp (define-ungrab/grab): Remove debug test Modified: clfswm/src/bindings.lisp clfswm/src/clfswm-keys.lisp Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Thu Aug 26 15:26:11 2010 @@ -68,10 +68,6 @@ ;; Second mode (define-main-key (#\t :mod-1) 'second-key-mode) (define-main-key ("less" :control) 'second-key-mode) - (define-main-key ("Z" :control) 'second-key-mode) - ;;(define-main-key (#\< :control) 'second-key-mode) - ;;(define-main-key (#x003c :control) 'second-key-mode) - ;;(define-main-key (94 :control) 'second-key-mode) ;; Bind or jump functions (define-main-key ("1" :mod-1) 'bind-or-jump 1) (define-main-key ("2" :mod-1) 'bind-or-jump 2) Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Thu Aug 26 15:26:11 2010 @@ -155,7 +155,6 @@ (unless found (setf modifiers (add-in-state modifiers :shift)))) ret-keycode))))) - (dbg key modifiers keycode) (if keycode (if (consp keycode) (dolist (kc (remove-duplicates keycode)) From pbrochard at common-lisp.net Thu Aug 26 21:29:45 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 26 Aug 2010 17:29:45 -0400 Subject: [clfswm-cvs] r302 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Aug 26 17:29:45 2010 New Revision: 302 Log: src/clfswm-circulate-mode.lisp (circulate-loop-function): Use is-a-key-pressed-p. src/xlib-util.lisp (is-a-key-pressed-p): New predicate. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Aug 26 17:29:45 2010 @@ -1,5 +1,10 @@ 2010-08-26 Philippe Brochard + * src/clfswm-circulate-mode.lisp (circulate-loop-function): + Use is-a-key-pressed-p. + + * src/xlib-util.lisp (is-a-key-pressed-p): New predicate. + * src/clfswm-keys.lisp (define-ungrab/grab): Use all values returned by xlib:keysym->keycodes. Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Thu Aug 26 17:29:45 2010 @@ -33,8 +33,6 @@ (defparameter *circulate-orig* nil) (defparameter *circulate-parent* nil) -(defparameter *circulate-leave-key* nil) - (defun draw-circulate-mode-window () (raise-window *circulate-window*) (clear-pixmap-buffer *circulate-window* *circulate-gc*) @@ -153,23 +151,6 @@ (define-circulate-release-key ("Alt_L" :alt) 'leave-circulate-mode)) -(defun set-circulate-leave-key () - (maphash #'(lambda (key value) - (when (and (listp value) (member 'leave-circulate-mode value)) - (setf *circulate-leave-key* (typecase (first key) - (character (list (char->keycode (first key)))) - (number (list (first key))) - (string (multiple-value-list - (xlib:keysym->keycodes *display* (keysym-name->keysym (first key))))))))) - *circulate-keys-release*)) - - - - - - - - (defun circulate-leave-function () (when *circulate-window* (xlib:destroy-window *circulate-window*)) @@ -180,15 +161,8 @@ *circulate-font* nil)) (defun circulate-loop-function () - ;;; Check if the key modifier is alway pressed - (let ((leave t)) - (loop for k across (xlib:query-keymap *display*) - for i from 0 - do (when (and (plusp k) (member i *circulate-leave-key*)) - (setf leave nil) - (return))) - (when leave - (leave-circulate-mode)))) + (unless (is-a-key-pressed-p) + (leave-circulate-mode))) (define-handler circulate-mode :key-press (code state) (unless (funcall-key-from-code *circulate-keys* code state) @@ -205,7 +179,6 @@ (defun circulate-mode (&key child-direction brother-direction) (setf *circulate-hit* 0) - (set-circulate-leave-key) (with-placement (*circulate-mode-placement* x y *circulate-width* *circulate-height*) (setf *circulate-font* (xlib:open-font *display* *circulate-font-string*) *circulate-window* (xlib:create-window :parent *root* Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Thu Aug 26 17:29:45 2010 @@ -732,7 +732,7 @@ "Alt_L" "Alt_R" "Meta_L" "Meta_R" "Hyper_L" "Hyper_R" "Mode_switch" "script_switch" "ISO_Level3_Shift" "Caps_Lock" "Scroll_Lock" "Num_Lock")) - (awhen (xlib:keysym->keycodes *display* (keysym-name->keysym name)) + (awhen (xlib:keysym->keycodes *display* (keysym-name->keysym name)) ;; PHIL: todo here (push it modifier-list)))) (defun modifier-p (code) @@ -801,3 +801,10 @@ (xlib:copy-area *pixmap-buffer* gc 0 0 (xlib:drawable-width window) (xlib:drawable-height window) window 0 0)) + + +(defun is-a-key-pressed-p () + (loop for k across (xlib:query-keymap *display*) + when (plusp k) + return t)) + From pbrochard at common-lisp.net Fri Aug 27 22:05:52 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 27 Aug 2010 18:05:52 -0400 Subject: [clfswm-cvs] r303 - in clfswm: . src Message-ID: Author: pbrochard Date: Fri Aug 27 18:05:51 2010 New Revision: 303 Log: main-mode:configure-request: Raise the window only when present on the current child and focus it accordingly. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-layout.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Fri Aug 27 18:05:51 2010 @@ -1,3 +1,12 @@ +2010-08-28 Philippe Brochard + + * src/clfswm-internal.lisp (is-in-current-child-p): New function. + +2010-08-27 Philippe Brochard + + * src/clfswm.lisp (main-mode:configure-request): Raise the window + only when present on the current child and focus it accordingly. + 2010-08-26 Philippe Brochard * src/clfswm-circulate-mode.lisp (circulate-loop-function): Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Fri Aug 27 18:05:51 2010 @@ -76,7 +76,7 @@ (let ((len (length *circulate-orig*))) (when (plusp len) (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*))) - (setf child (nconc (list elem) (remove elem *circulate-orig*))))) + (setf child (nconc (list elem) (remove elem *circulate-orig* :test #'child-equal-p))))) (show-all-children) (draw-circulate-mode-window)))) @@ -94,7 +94,7 @@ (when (plusp len) (when (frame-p *circulate-parent*) (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*))) - (setf (frame-child *circulate-parent*) (nconc (list elem) (remove elem *circulate-orig*)) + (setf (frame-child *circulate-parent*) (nconc (list elem) (remove elem *circulate-orig* :test #'child-equal-p)) *current-child* (frame-selected-child *circulate-parent*)))) (when frame-is-root? (setf *current-root* *current-child*)))) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Fri Aug 27 18:05:51 2010 @@ -110,11 +110,11 @@ (if (frame-p frame) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) frame - (and (not (member window unmanaged)) + (and (not (member window unmanaged :test #'child-equal-p)) (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) (or (member :all (frame-managed-type frame)) (member (window-type window) (frame-managed-type frame)) - (member window managed) + (member window managed :test #'child-equal-p) (member (xlib:wm-name window) managed :test #'string-equal-p)))) t)) @@ -200,6 +200,11 @@ (declare (ignore child name))) +(defun is-in-current-child-p (child) + (and (frame-p *current-child*) + (member child (frame-child *current-child*) :test #'child-equal-p))) + + ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child))))) (defmacro with-all-children ((root child) &body body) @@ -350,7 +355,7 @@ (defun find-parent-frame (to-find &optional (root *root-frame*) first-foundp) "Return the parent frame of to-find" (with-find-in-all-frames - (member to-find (frame-child frame)))) + (member to-find (frame-child frame) :test #'child-equal-p))) (defun find-frame-window (window &optional (root *root-frame*) first-foundp) "Return the frame with the window window" @@ -688,10 +693,10 @@ (defun focus-child (child parent) "Focus child - Return true if something has change" (when (and (frame-p parent) - (member child (frame-child parent))) + (member child (frame-child parent) :test #'child-equal-p)) (when (not (child-equal-p child (frame-selected-child parent))) (with-slots ((parent-child child) selected-pos) parent - (setf parent-child (nth-insert selected-pos child (remove child parent-child)))) + (setf parent-child (nth-insert selected-pos child (remove child parent-child :test #'child-equal-p)))) t))) (defun focus-child-rec (child parent) @@ -949,7 +954,7 @@ (let ((id-list nil) (all-windows (get-all-windows))) (dolist (win (xlib:query-tree (xlib:screen-root screen))) - (unless (member win all-windows) + (unless (member win all-windows :test #'child-equal-p) (let ((map-state (xlib:window-map-state win)) (wm-state (window-state win))) (unless (or (eql (xlib:window-override-redirect win) :on) Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Fri Aug 27 18:05:51 2010 @@ -195,7 +195,7 @@ (let ((managed-children (frame-data-slot parent :layout-managed-children)) (managed-in-parent (get-managed-child parent))) (dolist (ch managed-in-parent) - (unless (member ch managed-children) + (unless (member ch managed-children :test #'child-equal-p) (setf managed-children (append managed-children (list child))))) (setf managed-children (remove-if-not (lambda (x) (member x managed-in-parent :test #'child-equal-p)) @@ -515,7 +515,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows) + (if (member child main-windows :test #'child-equal-p) (let* ((dy (/ rh len)) (pos (position child main-windows))) (values (1+ (round (+ rx (* rw (- 1 size))))) @@ -543,7 +543,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows) + (if (member child main-windows :test #'child-equal-p) (let* ((dy (/ rh len)) (pos (position child main-windows))) (values (1+ rx) @@ -570,7 +570,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows) + (if (member child main-windows :test #'child-equal-p) (let* ((dx (/ rw len)) (pos (position child main-windows))) (values (1+ (round (+ rx (* dx pos)))) @@ -597,7 +597,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows) + (if (member child main-windows :test #'child-equal-p) (let* ((dx (/ rw len)) (pos (position child main-windows))) (values (1+ (round (+ rx (* dx pos)))) @@ -622,7 +622,7 @@ "Add the current window in the main window list" (when (frame-p *current-child*) (with-current-window - (when (member window (get-managed-child *current-child*)) + (when (member window (get-managed-child *current-child*) :test #'child-equal-p) (pushnew window (frame-data-slot *current-child* :main-window-list))))) (leave-second-mode)) @@ -631,9 +631,9 @@ "Remove the current window from the main window list" (when (frame-p *current-child*) (with-current-window - (when (member window (get-managed-child *current-child*)) + (when (member window (get-managed-child *current-child*) :test #'child-equal-p) (setf (frame-data-slot *current-child* :main-window-list) - (remove window (frame-data-slot *current-child* :main-window-list)))))) + (remove window (frame-data-slot *current-child* :main-window-list) :test #'child-equal-p))))) (leave-second-mode)) (defun clear-main-window-list () @@ -667,7 +667,7 @@ (labels ((rec () (setf child (funcall fun-rotate child)) (when (and to-skip? - (member (frame-selected-child *current-child*) main-windows)) + (member (frame-selected-child *current-child*) main-windows :test #'child-equal-p)) (rec)))) (unselect-all-frames) (rec) @@ -688,7 +688,7 @@ Or do actions on corners - Skip windows in main window list" (unless (do-corner-action root-x root-y *corner-main-mode-left-button*) (if (and (frame-p *current-child*) - (member window (frame-data-slot *current-child* :main-window-list))) + (member window (frame-data-slot *current-child* :main-window-list) :test #'child-equal-p)) (replay-button-event) (mouse-click-to-focus-generic window root-x root-y #'move-frame)))) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Fri Aug 27 18:05:51 2010 @@ -970,7 +970,7 @@ (let ((parent (find-parent-frame window))) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) parent - (setf unmanaged (remove window unmanaged) + (setf unmanaged (remove window unmanaged :test #'child-equal-p) unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p)) (pushnew window managed)))) (leave-second-mode)) @@ -981,7 +981,7 @@ (let ((parent (find-parent-frame window))) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) parent - (setf managed (remove window managed) + (setf managed (remove window managed :test #'child-equal-p) managed (remove (xlib:wm-name window) managed :test #'string-equal-p)) (pushnew window unmanaged)))) (leave-second-mode)) @@ -1036,7 +1036,7 @@ (when (frame-p parent) (with-slots (child hidden-children) parent (hide-all *current-child*) - (setf child (remove *current-child* child)) + (setf child (remove *current-child* child :test #'child-equal-p)) (pushnew *current-child* hidden-children) (setf *current-child* parent)) (show-all-children))) @@ -1046,7 +1046,7 @@ (defun frame-unhide-child (hidden frame-src frame-dest) "Unhide a hidden child from frame-src in frame-dest" (with-slots (hidden-children) frame-src - (setf hidden-children (remove hidden hidden-children))) + (setf hidden-children (remove hidden hidden-children :test #'child-equal-p))) (with-slots (child) frame-dest (pushnew hidden child))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Fri Aug 27 18:05:51 2010 @@ -70,7 +70,13 @@ (xlib:drawable-border-width window)) (when (has-stackmode value-mask) (case stack-mode - (:above (raise-window window)))))))) + (:above + (when (or (child-equal-p window *current-child*) + (is-in-current-child-p window)) + (raise-window window) + (focus-window window) + (focus-all-children window (find-parent-frame window *current-root*)))))))))) + (define-handler main-mode :map-request (window send-event-p) (unless send-event-p @@ -103,7 +109,7 @@ *default-focus-policy*) (:sloppy (focus-window window)) (:sloppy-strict (when (and (frame-p *current-child*) - (member window (frame-child *current-child*))) + (member window (frame-child *current-child*) :test #'child-equal-p)) (focus-window window))) (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child))) From pbrochard at common-lisp.net Sat Aug 28 20:50:34 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 28 Aug 2010 16:50:34 -0400 Subject: [clfswm-cvs] r304 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Aug 28 16:50:34 2010 New Revision: 304 Log: src/clfswm.lisp (main-loop): Ensure that all events have been processed after a process-event. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Aug 28 16:50:34 2010 @@ -1,5 +1,8 @@ 2010-08-28 Philippe Brochard + * src/clfswm.lisp (main-loop): Ensure that all events have been + processed after a process-event. + * src/clfswm-internal.lisp (is-in-current-child-p): New function. 2010-08-27 Philippe Brochard Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Aug 28 16:50:34 2010 @@ -321,7 +321,8 @@ (loop until done do (xlib:display-finish-output *display*) (when (xlib:event-listen *display* *loop-timeout*) - (xlib:process-event *display* :handler #'handle-identify))) + (xlib:process-event *display* :handler #'handle-identify)) + (xlib:display-finish-output *display*)) (xlib:destroy-window window) (xlib:close-font font) (xgrab-pointer *root* 66 67))))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Aug 28 16:50:34 2010 @@ -132,7 +132,8 @@ (call-hook *loop-hook*) (xlib:display-finish-output *display*) (when (xlib:event-listen *display* *loop-timeout*) - (xlib:process-event *display* :handler #'handle-event))))) + (xlib:process-event *display* :handler #'handle-event)) + (xlib:display-finish-output *display*)))) ;;(dbg "Main loop finish" c))))) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sat Aug 28 16:50:34 2010 @@ -219,7 +219,6 @@ (when window (with-xlib-protect (when (window-hidden-p window) - (xlib:map-subwindows window) (xlib:map-window window) (setf (window-state window) +normal-state+ (xlib:window-event-mask window) *window-events*)))) @@ -229,7 +228,6 @@ (defun map-window (window) (when window (with-xlib-protect - (xlib:map-subwindows window) (xlib:map-window window) (xlib:display-finish-output *display*)))) @@ -732,7 +730,7 @@ "Alt_L" "Alt_R" "Meta_L" "Meta_R" "Hyper_L" "Hyper_R" "Mode_switch" "script_switch" "ISO_Level3_Shift" "Caps_Lock" "Scroll_Lock" "Num_Lock")) - (awhen (xlib:keysym->keycodes *display* (keysym-name->keysym name)) ;; PHIL: todo here + (awhen (xlib:keysym->keycodes *display* (keysym-name->keysym name)) (push it modifier-list)))) (defun modifier-p (code) From pbrochard at common-lisp.net Sat Aug 28 21:35:15 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 28 Aug 2010 17:35:15 -0400 Subject: [clfswm-cvs] r305 - clfswm/src Message-ID: Author: pbrochard Date: Sat Aug 28 17:35:15 2010 New Revision: 305 Log: main-mode:configure-request: Do not raise fullscreened windows. Modified: clfswm/src/clfswm.lisp Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Aug 28 17:35:15 2010 @@ -71,11 +71,12 @@ (when (has-stackmode value-mask) (case stack-mode (:above - (when (or (child-equal-p window *current-child*) - (is-in-current-child-p window)) - (raise-window window) - (focus-window window) - (focus-all-children window (find-parent-frame window *current-root*)))))))))) + (unless (null-size-window-p window) + (when (or (child-equal-p window *current-child*) + (is-in-current-child-p window)) + (raise-window window) + (focus-window window) + (focus-all-children window (find-parent-frame window *current-root*))))))))))) (define-handler main-mode :map-request (window send-event-p) @@ -91,7 +92,8 @@ (not (xlib:window-equal window event-window))) (when (find-child window *root-frame*) (delete-child-in-all-frames window) - (show-all-children)))) + (unless (null-size-window-p window) + (show-all-children))))) (define-handler main-mode :destroy-notify (send-event-p event-window window) @@ -99,7 +101,8 @@ (xlib:window-equal window event-window)) (when (find-child window *root-frame*) (delete-child-in-all-frames window) - (show-all-children)))) + (unless (null-size-window-p window) + (show-all-children))))) (define-handler main-mode :enter-notify (window root-x root-y) (unless (and (> root-x (- (xlib:screen-width *screen*) 3)) From pbrochard at common-lisp.net Sun Aug 29 11:47:52 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 29 Aug 2010 07:47:52 -0400 Subject: [clfswm-cvs] r306 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Aug 29 07:47:52 2010 New Revision: 306 Log: child-member, child-remove: New predicates. src/*.lisp: Use child-member and child-remove everywhere it's needed. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-layout.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Aug 29 07:47:52 2010 @@ -1,3 +1,11 @@ +2010-08-29 Philippe Brochard + + * src/clfswm-internal.lisp (child-member): New predicate. + (child-remove): New function. + + * src/*.lisp: Use child-member and child-remove everywhere it's + needed. + 2010-08-28 Philippe Brochard * src/clfswm.lisp (main-loop): Ensure that all events have been Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Sun Aug 29 07:47:52 2010 @@ -76,7 +76,7 @@ (let ((len (length *circulate-orig*))) (when (plusp len) (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*))) - (setf child (nconc (list elem) (remove elem *circulate-orig* :test #'child-equal-p))))) + (setf child (nconc (list elem) (child-remove elem *circulate-orig*))))) (show-all-children) (draw-circulate-mode-window)))) @@ -94,7 +94,7 @@ (when (plusp len) (when (frame-p *circulate-parent*) (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*))) - (setf (frame-child *circulate-parent*) (nconc (list elem) (remove elem *circulate-orig* :test #'child-equal-p)) + (setf (frame-child *circulate-parent*) (nconc (list elem) (child-remove elem *circulate-orig*)) *current-child* (frame-selected-child *circulate-parent*)))) (when frame-is-root? (setf *current-root* *current-child*)))) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sun Aug 29 07:47:52 2010 @@ -88,6 +88,31 @@ + +(defgeneric child-equal-p (child-1 child-2)) + +(defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window)) + (xlib:window-equal child-1 child-2)) + +(defmethod child-equal-p ((child-1 frame) (child-2 frame)) + (equal child-1 child-2)) + +(defmethod child-equal-p (child-1 child-2) + (declare (ignore child-1 child-2)) + nil) + + +(declaim (inline child-member child-remove)) + +(defun child-member (child list) + (member child list :test #'child-equal-p)) + +(defun child-remove (child list) + (remove child list :test #'child-equal-p)) + + + + ;;; Frame data manipulation functions (defun frame-data-slot (frame slot) "Return the value associated to data slot" @@ -110,11 +135,11 @@ (if (frame-p frame) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) frame - (and (not (member window unmanaged :test #'child-equal-p)) + (and (not (child-member window unmanaged)) (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) (or (member :all (frame-managed-type frame)) (member (window-type window) (frame-managed-type frame)) - (member window managed :test #'child-equal-p) + (child-member window managed) (member (xlib:wm-name window) managed :test #'string-equal-p)))) t)) @@ -126,21 +151,6 @@ - -(defgeneric child-equal-p (child-1 child-2)) - -(defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window)) - (xlib:window-equal child-1 child-2)) - -(defmethod child-equal-p ((child-1 frame) (child-2 frame)) - (equal child-1 child-2)) - -(defmethod child-equal-p (child-1 child-2) - (declare (ignore child-1 child-2)) - nil) - - - (defgeneric child-name (child)) (defmethod child-name ((child xlib:window)) @@ -202,7 +212,7 @@ (defun is-in-current-child-p (child) (and (frame-p *current-child*) - (member child (frame-child *current-child*) :test #'child-equal-p))) + (child-member child (frame-child *current-child*)))) @@ -355,7 +365,7 @@ (defun find-parent-frame (to-find &optional (root *root-frame*) first-foundp) "Return the parent frame of to-find" (with-find-in-all-frames - (member to-find (frame-child frame) :test #'child-equal-p))) + (child-member to-find (frame-child frame)))) (defun find-frame-window (window &optional (root *root-frame*) first-foundp) "Return the frame with the window window" @@ -693,10 +703,10 @@ (defun focus-child (child parent) "Focus child - Return true if something has change" (when (and (frame-p parent) - (member child (frame-child parent) :test #'child-equal-p)) + (child-member child (frame-child parent))) (when (not (child-equal-p child (frame-selected-child parent))) (with-slots ((parent-child child) selected-pos) parent - (setf parent-child (nth-insert selected-pos child (remove child parent-child :test #'child-equal-p)))) + (setf parent-child (nth-insert selected-pos child (child-remove child parent-child)))) t))) (defun focus-child-rec (child parent) @@ -835,7 +845,7 @@ (defun remove-child-in-frame (child frame) "Remove the child in frame" (when (frame-p frame) - (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p)))) + (setf (frame-child frame) (child-remove child (frame-child frame))))) (defun remove-child-in-frames (child root) "Remove child in the frame root and in all its children" @@ -954,7 +964,7 @@ (let ((id-list nil) (all-windows (get-all-windows))) (dolist (win (xlib:query-tree (xlib:screen-root screen))) - (unless (member win all-windows :test #'child-equal-p) + (unless (child-member win all-windows) (let ((map-state (xlib:window-map-state win)) (wm-state (window-state win))) (unless (or (eql (xlib:window-override-redirect win) :on) Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Sun Aug 29 07:47:52 2010 @@ -195,10 +195,10 @@ (let ((managed-children (frame-data-slot parent :layout-managed-children)) (managed-in-parent (get-managed-child parent))) (dolist (ch managed-in-parent) - (unless (member ch managed-children :test #'child-equal-p) + (unless (child-member ch managed-children) (setf managed-children (append managed-children (list child))))) (setf managed-children (remove-if-not (lambda (x) - (member x managed-in-parent :test #'child-equal-p)) + (child-member x managed-in-parent)) managed-children)) (setf (frame-data-slot parent :layout-managed-children) managed-children) managed-children)) @@ -515,7 +515,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows :test #'child-equal-p) + (if (child-member child main-windows) (let* ((dy (/ rh len)) (pos (position child main-windows))) (values (1+ (round (+ rx (* rw (- 1 size))))) @@ -543,7 +543,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows :test #'child-equal-p) + (if (child-member child main-windows) (let* ((dy (/ rh len)) (pos (position child main-windows))) (values (1+ rx) @@ -570,7 +570,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows :test #'child-equal-p) + (if (child-member child main-windows) (let* ((dx (/ rw len)) (pos (position child main-windows))) (values (1+ (round (+ rx (* dx pos)))) @@ -597,7 +597,7 @@ (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) - (if (member child main-windows :test #'child-equal-p) + (if (child-member child main-windows) (let* ((dx (/ rw len)) (pos (position child main-windows))) (values (1+ (round (+ rx (* dx pos)))) @@ -622,7 +622,7 @@ "Add the current window in the main window list" (when (frame-p *current-child*) (with-current-window - (when (member window (get-managed-child *current-child*) :test #'child-equal-p) + (when (child-member window (get-managed-child *current-child*)) (pushnew window (frame-data-slot *current-child* :main-window-list))))) (leave-second-mode)) @@ -631,9 +631,9 @@ "Remove the current window from the main window list" (when (frame-p *current-child*) (with-current-window - (when (member window (get-managed-child *current-child*) :test #'child-equal-p) + (when (child-member window (get-managed-child *current-child*)) (setf (frame-data-slot *current-child* :main-window-list) - (remove window (frame-data-slot *current-child* :main-window-list) :test #'child-equal-p))))) + (child-remove window (frame-data-slot *current-child* :main-window-list)))))) (leave-second-mode)) (defun clear-main-window-list () @@ -667,7 +667,7 @@ (labels ((rec () (setf child (funcall fun-rotate child)) (when (and to-skip? - (member (frame-selected-child *current-child*) main-windows :test #'child-equal-p)) + (child-member (frame-selected-child *current-child*) main-windows)) (rec)))) (unselect-all-frames) (rec) @@ -688,7 +688,7 @@ Or do actions on corners - Skip windows in main window list" (unless (do-corner-action root-x root-y *corner-main-mode-left-button*) (if (and (frame-p *current-child*) - (member window (frame-data-slot *current-child* :main-window-list) :test #'child-equal-p)) + (child-member window (frame-data-slot *current-child* :main-window-list))) (replay-button-event) (mouse-click-to-focus-generic window root-x root-y #'move-frame)))) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Aug 29 07:47:52 2010 @@ -971,7 +971,7 @@ (let ((parent (find-parent-frame window))) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) parent - (setf unmanaged (remove window unmanaged :test #'child-equal-p) + (setf unmanaged (child-remove window unmanaged) unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p)) (pushnew window managed)))) (leave-second-mode)) @@ -982,7 +982,7 @@ (let ((parent (find-parent-frame window))) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) parent - (setf managed (remove window managed :test #'child-equal-p) + (setf managed (child-remove window managed) managed (remove (xlib:wm-name window) managed :test #'string-equal-p)) (pushnew window unmanaged)))) (leave-second-mode)) @@ -1037,7 +1037,7 @@ (when (frame-p parent) (with-slots (child hidden-children) parent (hide-all *current-child*) - (setf child (remove *current-child* child :test #'child-equal-p)) + (setf child (child-remove *current-child* child)) (pushnew *current-child* hidden-children) (setf *current-child* parent)) (show-all-children))) @@ -1047,7 +1047,7 @@ (defun frame-unhide-child (hidden frame-src frame-dest) "Unhide a hidden child from frame-src in frame-dest" (with-slots (hidden-children) frame-src - (setf hidden-children (remove hidden hidden-children :test #'child-equal-p))) + (setf hidden-children (child-remove hidden hidden-children))) (with-slots (child) frame-dest (pushnew hidden child))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sun Aug 29 07:47:52 2010 @@ -92,8 +92,7 @@ (not (xlib:window-equal window event-window))) (when (find-child window *root-frame*) (delete-child-in-all-frames window) - (unless (null-size-window-p window) - (show-all-children))))) + (show-all-children)))) (define-handler main-mode :destroy-notify (send-event-p event-window window) @@ -101,8 +100,7 @@ (xlib:window-equal window event-window)) (when (find-child window *root-frame*) (delete-child-in-all-frames window) - (unless (null-size-window-p window) - (show-all-children))))) + (show-all-children)))) (define-handler main-mode :enter-notify (window root-x root-y) (unless (and (> root-x (- (xlib:screen-width *screen*) 3)) @@ -112,7 +110,7 @@ *default-focus-policy*) (:sloppy (focus-window window)) (:sloppy-strict (when (and (frame-p *current-child*) - (member window (frame-child *current-child*) :test #'child-equal-p)) + (child-member window (frame-child *current-child*))) (focus-window window))) (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child))) From pbrochard at common-lisp.net Sun Aug 29 12:01:06 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 29 Aug 2010 08:01:06 -0400 Subject: [clfswm-cvs] r307 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Aug 29 08:01:04 2010 New Revision: 307 Log: hide-current-child: Prevent from removing the current root. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Aug 29 08:01:04 2010 @@ -1,5 +1,8 @@ 2010-08-29 Philippe Brochard + * src/clfswm-util.lisp (hide-current-child): Prevent from removing + the current root. + * src/clfswm-internal.lisp (child-member): New predicate. (child-remove): New function. Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Aug 29 08:01:04 2010 @@ -1033,15 +1033,16 @@ ;;; Hide/Unhide current child (defun hide-current-child () "Hide the current child" - (let ((parent (find-parent-frame *current-child*))) - (when (frame-p parent) - (with-slots (child hidden-children) parent - (hide-all *current-child*) - (setf child (child-remove *current-child* child)) - (pushnew *current-child* hidden-children) - (setf *current-child* parent)) - (show-all-children))) - (leave-second-mode)) + (unless (child-equal-p *current-child* *current-root*) + (let ((parent (find-parent-frame *current-child*))) + (when (frame-p parent) + (with-slots (child hidden-children) parent + (hide-all *current-child*) + (setf child (child-remove *current-child* child)) + (pushnew *current-child* hidden-children) + (setf *current-child* parent)) + (show-all-children))) + (leave-second-mode))) (defun frame-unhide-child (hidden frame-src frame-dest) From pbrochard at common-lisp.net Sun Aug 29 21:04:41 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 29 Aug 2010 17:04:41 -0400 Subject: [clfswm-cvs] r308 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Aug 29 17:04:41 2010 New Revision: 308 Log: run-other-window-manager: Update for clisp compatibility. Modified: clfswm/ChangeLog clfswm/src/clfswm-info.lisp clfswm/src/clfswm-util.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Aug 29 17:04:41 2010 @@ -1,5 +1,11 @@ 2010-08-29 Philippe Brochard + * src/clfswm-util.lisp (run-other-window-manager): Update for + clisp compatibility. + + * src/tools.lisp (do-execute): New parameter io to change the + input/output method. + * src/clfswm-util.lisp (hide-current-child): Prevent from removing the current root. Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Sun Aug 29 17:04:41 2010 @@ -537,6 +537,7 @@ collect line))))) + (defun show-cpu-proc () "Show current processes sorted by CPU usage" (info-on-shell "Current processes sorted by CPU usage:" Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Aug 29 17:04:41 2010 @@ -1282,9 +1282,8 @@ ;;; Other window manager functions (defun get-proc-list () - (let ((proc (do-shell "ps x -o pid=" nil nil)) + (let ((proc (do-shell "ps x -o pid=" nil t)) (proc-list nil)) - (sleep 0.5) (loop for line = (read-line proc nil nil) while line do (push line proc-list)) @@ -1293,17 +1292,14 @@ (defun run-other-window-manager () (let ((proc-start (get-proc-list))) - (do-shell *other-window-manager* nil t) + (do-shell *other-window-manager* nil t :terminal) (let* ((proc-end (get-proc-list)) (proc-diff (set-difference proc-end proc-start :test #'equal))) - (dbg proc-diff) - (dolist (proc proc-diff) - (dbg 'killing-sigterm proc) - (do-shell (format nil "kill ~A 2> /dev/null" proc) nil t)) - (sleep 0.5) - (dolist (proc proc-diff) - (dbg 'killing-sigkill proc) - (do-shell (format nil "kill -9 ~A 2> /dev/null" proc) nil t))) + (dbg 'killing-sigterm proc-diff) + (do-shell (format nil "kill ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal) + (dbg 'killing-sigkill proc-diff) + (do-shell (format nil "kill -9 ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal) + (sleep 1)) (setf *other-window-manager* nil))) @@ -1326,7 +1322,11 @@ (defun run-lxde () "Run LXDE" - (do-run-other-window-manager "lxsession; xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\"")) + (do-run-other-window-manager "( lxsession & ); xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\"")) + +(defun run-xfce4 () + "Run LXDE (xterm)" + (do-run-other-window-manager "( xfce4-session &) ; xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\"")) (defun run-prompt-wm () Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sun Aug 29 17:04:41 2010 @@ -434,37 +434,23 @@ ;;; Shell part (taken from ltk) -(defun do-execute (program args &optional (wt nil)) +(defun do-execute (program args &optional (wt nil) (io :stream)) "execute program with args a list containing the arguments passed to the program if wt is non-nil, the function will wait for the execution of the program to return. returns a two way stream connected to stdin/stdout of the program" + #-CLISP (declare (ignore io)) (let ((fullstring program)) (dolist (a args) (setf fullstring (concatenate 'string fullstring " " a))) - #+:cmu (let ((proc (ext:run-program program args :input :stream - :output :stream :wait wt))) + #+:cmu (let ((proc (ext:run-program program args :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream (ext:process-output proc) (ext:process-input proc))) - ;; #+:clisp (let ((proc (ext:run-program program :arguments args - ;; :input :stream :output :stream :wait (or wt t)))) - ;; (unless proc - ;; (error "Cannot create process.")) - ;; proc) - #+:clisp (if wt - (ext:run-program program :arguments args - :input :terminal :output :terminal :wait t) - (let ((proc (ext:run-program program :arguments args - :input :stream :output :stream :wait wt))) - (unless proc - (error "Cannot create process.")) - proc)) - #+:sbcl (let ((proc (sb-ext:run-program program args :input - :stream :output - :stream :wait wt))) + #+:clisp (ext:run-program program :arguments args :input io :output io :wait wt) + #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream @@ -488,9 +474,8 @@ (ccl:external-process-output-stream proc) (ccl:external-process-input-stream proc))))) -(defun do-shell (program &optional args (wt nil)) - (do-execute "/bin/sh" `("-c" ,program , at args) wt)) - +(defun do-shell (program &optional args (wait nil) (io :stream)) + (do-execute "/bin/sh" `("-c" ,program , at args) wait io)) From pbrochard at common-lisp.net Mon Aug 30 20:16:41 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 30 Aug 2010 16:16:41 -0400 Subject: [clfswm-cvs] r309 - in clfswm: . src Message-ID: Author: pbrochard Date: Mon Aug 30 16:16:40 2010 New Revision: 309 Log: src/clfswm-corner.lisp (present-clfswm-terminal): Make the clfswm terminal working even on xterm title changes. Modified: clfswm/ChangeLog clfswm/src/clfswm-corner.lisp clfswm/src/config.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Aug 30 16:16:40 2010 @@ -1,3 +1,8 @@ +2010-08-30 Philippe Brochard + + * src/clfswm-corner.lisp (present-clfswm-terminal): Make the + clfswm terminal working even on xterm title changes. + 2010-08-29 Philippe Brochard * src/clfswm-util.lisp (run-other-window-manager): Update for Modified: clfswm/src/clfswm-corner.lisp ============================================================================== --- clfswm/src/clfswm-corner.lisp (original) +++ clfswm/src/clfswm-corner.lisp Mon Aug 30 16:16:40 2010 @@ -120,30 +120,25 @@ t) - (defun present-clfswm-terminal () "Hide/Unhide a terminal" - (stop-button-event) - (let ((found nil)) - (dolist (win (xlib:query-tree *root*)) - (when (string-equal (xlib:wm-name win) *clfswm-terminal-name*) - (setf found t) - (unless (child-equal-p *clfswm-terminal* win) - (setf *clfswm-terminal* win) - (hide-window *clfswm-terminal*)))) - (unless found + (labels ((find-clfswm-terminal () + (dolist (win (xlib:query-tree *root*)) + (when (child-equal-p win *clfswm-terminal*) + (return t))))) + (stop-button-event) + (unless (find-clfswm-terminal) (do-shell *clfswm-terminal-cmd*) (loop :with done = nil :until done :do (dolist (win (xlib:query-tree *root*)) (when (string-equal (xlib:wm-name win) *clfswm-terminal-name*) (setf *clfswm-terminal* win done t)))) - (hide-window *clfswm-terminal*))) - (cond ((window-hidden-p *clfswm-terminal*) (unhide-window *clfswm-terminal*) - (focus-window *clfswm-terminal*) - (raise-window *clfswm-terminal*)) - (t (hide-window *clfswm-terminal*) - (show-all-children nil))) - t) - + (hide-window *clfswm-terminal*)) + (cond ((window-hidden-p *clfswm-terminal*) (unhide-window *clfswm-terminal*) + (focus-window *clfswm-terminal*) + (raise-window *clfswm-terminal*)) + (t (hide-window *clfswm-terminal*) + (show-all-children nil))) + t)) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Mon Aug 30 16:16:40 2010 @@ -128,6 +128,7 @@ (defparameter *clfswm-terminal-name* "clfswm-terminal" "Config(Corner group): The clfswm terminal name") +;;(defparameter *clfswm-terminal-cmd* (format nil "xterm -T ~A -e /bin/bash --noprofile --norc" *clfswm-terminal-name*) (defparameter *clfswm-terminal-cmd* (format nil "xterm -T ~A" *clfswm-terminal-name*) "Config(Corner group): The clfswm terminal command. This command must set the window title to *clfswm-terminal-name*")