diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\load-bits.lisp corman\load-bits.lisp --- corman3\load-bits.lisp Wed Dec 31 16:00:00 1969 +++ corman\load-bits.lisp Wed Jan 18 11:13:40 2006 @@ -0,0 +1,8 @@ +(require 'misc-ansi) +(require 'composite-streams) +(require 'lp) +(require 'sockets) +(require 'winbase) + +;; Reset an internal state variable in sockets +(setq sockets::*sockets-started* nil) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\asdf-addons.lisp corman\Modules\asdf-addons.lisp --- corman3\Modules\asdf-addons.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\asdf-addons.lisp Wed Sep 13 22:21:32 2006 @@ -0,0 +1,56 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/corman-asdf/asdf-addons.lisp,v 1.1 2004/05/06 10:59:48 edi Exp $ + +;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :asdf-util + (:use :cl) + (:export #:source-dir-search + #:*source-dirs*)) + +(in-package :asdf-util) + +(defparameter *source-dirs*) + +(defun source-dir-search (system) + (let ((name (asdf::coerce-name system))) + (dolist (source-dir *source-dirs*) + (dolist (subdir (cl::directory-subdirs source-dir)) + (let ((file (merge-pathnames + (make-pathname :name name + :type "asd" + :version :newest + :directory nil + :host nil + :device nil) + subdir))) + (when (probe-file file) + (return-from source-dir-search file))))))) + +(in-package :cl-user) \ No newline at end of file diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\asdf-patch.lisp corman\Modules\asdf-patch.lisp --- corman3\Modules\asdf-patch.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\asdf-patch.lisp Thu Jun 08 16:45:56 2006 @@ -0,0 +1,115 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/corman-asdf/patch.lisp,v 1.4 2004/05/06 10:59:48 edi Exp $ + +;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :win32) + +(defun ccl::set-current-directory (dir) + (let ((ret (_chdir (namestring dir)))) + (if (= ret -1) + (error "Could not set current directory to ~A" dir) + (setq *default-pathname-defaults* + (pl::get-current-directory))))) + +(defun subdirectory-pathname (directory-pathname subdir-name &key (name nil) (type nil) (version nil)) + (let ((p1 (parse-namestring subdir-name))) + (truename + (make-pathname + :host (pathname-host directory-pathname) + :device (pathname-device directory-pathname) + :directory + (append + (pathname-directory directory-pathname) + (list (if (pathname-type p1) + (format nil "~A.~A" (pathname-name p1) (pathname-type p1)) + (pathname-name p1)))) + :name name + :type type + :version version)))) + +(in-package :pathnames) + +(defun make-pathname-internal (&key + (host (pathname-internal-host *default-pathname-defaults*) supplied-host) + (device nil supplied-device) + (directory nil supplied-directory) + (name nil supplied-name) + (type nil supplied-type) + (version :unspecific supplied-version) + (defaults nil) + (case :local)) + (declare (ignore case)) + (when defaults + (setq defaults (pathname defaults)) + (unless supplied-host (setq host (pathname-internal-host defaults))) + (unless supplied-device (setq device (pathname-internal-device defaults))) + (unless supplied-directory (setq directory (pathname-internal-directory defaults))) + (unless supplied-name (setq name (pathname-internal-name defaults))) + (unless supplied-type (setq type (pathname-internal-type defaults))) + (unless supplied-version (setq version (pathname-internal-version defaults)))) + (construct-pathname host device directory name type version)) + +(in-package :common-lisp) + +(pushnew :broken-fasl-loader *features*) + +(defmacro in-package (name) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (let ((package (find-package ',name))) + (cond (package + (setq *package* package)) + (t + (cerror "Create a new package named ~S." + (make-condition 'package-error + :package ',name + :format-control "Package ~S not found." + :format-arguments (list ',name)) + ',name) + (setq *package* (make-package ',name))))))) + +(defmacro define-modify-macro (name lambda-list function &optional documentation) + (let* ((place (gensym)) + (rest-arg (second (member '&rest lambda-list :test #'eq))) + (other-args (mapcar (lambda (arg) + (if (consp arg) (first arg) arg)) + (remove '&optional + (if rest-arg (butlast lambda-list 2) lambda-list) + :test #'eq)))) + (flet ((fn-form (new-arg) + (if rest-arg + `(append (list 'funcall #',function ,new-arg ,@other-args) ,rest-arg) + `(list 'funcall #',function ,new-arg ,@other-args)))) + `(defmacro ,name (,place ,@lambda-list &environment env) + ,@(if documentation (list documentation)) + (multiple-value-bind (vars vals new setter getter) + (get-setf-expansion ,place env) + (declare (ignore setter)) + `(let* (,@(mapcar 'list vars vals) (,(car new) ,getter)) + (setf ,getter ,,(fn-form '(car new))))))))) + +(in-package :cl-user) \ No newline at end of file diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\asdf.lisp corman\Modules\asdf.lisp --- corman3\Modules\asdf.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\asdf.lisp Sun Sep 17 17:54:14 2006 @@ -0,0 +1,1173 @@ +;;; This is asdf: Another System Definition Facility. $Revision: 1.98 $ +;;; +;;; Feedback, bug reports, and patches are all welcome: please mail to +;;; . But note first that the canonical +;;; source for asdf is presently the cCLan CVS repository at +;;; +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the CVS HEAD +;;; is the latest development version, whereas the revision tagged +;;; RELEASE may be slightly older but is considered `stable' + +;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;;; the problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file + +(defpackage #:asdf + (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:hyperdocumentation #:hyperdoc + + #:compile-op #:load-op #:load-source-op #:test-system-version + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + + #:operation-on-warnings + #:operation-on-failure + + ;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*asdf-revision* + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + #:duplicate-names + + #:retry + #:accept ; restarts + + ) + (:use :cl)) + +#+nil +(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") + + +(in-package #:asdf) + +(defvar *asdf-revision* (let* ((v "$Revision: 1.98 $") + (colon (or (position #\: v) -1)) + (dot (position #\. v))) + (and v colon dot + (list (parse-integer v :start (1+ colon) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t))))) + +(defvar *compile-file-warnings-behaviour* :warn) +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) + +(defvar *verbose-out* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utility stuff + +(defmacro aif (test then &optional else) + `(let ((it ,test)) (if it ,then ,else))) + +(defun pathname-sans-name+type (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME and TYPE components" + (make-pathname :name nil :type nil :defaults pathname)) + +(define-modify-macro appendf (&rest args) + append "Append onto list") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; classes, condiitons + +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + +(define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply #'format s (format-control c) (format-arguments c))))) + +(define-condition circular-dependency (system-definition-error) + ((components :initarg :components :reader circular-dependency-components))) + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (version :initform nil :reader missing-version :initarg :version) + (parent :initform nil :reader missing-parent :initarg :parent))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(define-condition operation-error (error) + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s "~@" + (error-operation c) (error-component c))))) +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + +(defclass component () + ((name :accessor component-name :initarg :name :documentation + "Component name: designator for a string composed of portable pathname characters") + (version :accessor component-version :initarg :version) + (in-order-to :initform nil :initarg :in-order-to) + ;;; XXX crap name + (do-first :initform nil :initarg :do-first) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) + (parent :initarg :parent :initform nil :reader component-parent) + ;; no direct accessor for pathname, we do this as a method to allow + ;; it to default in funky ways if not supplied + (relative-pathname :initarg :pathname) + (operation-times :initform (make-hash-table ) + :accessor component-operation-times) + ;; XXX we should provide some atomic interface for updating the + ;; component properties + (properties :accessor component-properties :initarg :properties + :initform nil))) + +;;;; methods: conditions + +(defmethod print-object ((c missing-dependency) s) + (format s "~@<~A, required by ~A~@:>" + (call-next-method c nil) (missing-required-by c))) + +(defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) + +;;;; methods: components + +(defmethod print-object ((c missing-component) s) + (format s "~@" + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) + +(defgeneric component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defmethod component-system ((component component)) + (aif (component-parent component) + (component-system it) + component)) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity t) + (ignore-errors + (prin1 (component-name c) stream)))) + +(defclass module (component) + ((components :initform nil :accessor module-components :initarg :components) + ;; what to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing + (if-component-dep-fails :initform :fail + :accessor module-if-component-dep-fails + :initarg :if-component-dep-fails) + (default-component-class :accessor module-default-component-class + :initform 'cl-source-file :initarg :default-component-class))) + +(defgeneric component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defun component-parent-pathname (component) + (aif (component-parent component) + (component-pathname it) + *default-pathname-defaults*)) + +(defgeneric component-relative-pathname (component) + (:documentation "Extracts the relative pathname applicable for a particular component.")) + +(defmethod component-relative-pathname ((component module)) + (or (slot-value component 'relative-pathname) + (make-pathname + :directory `(:relative ,(component-name component)) + :host (pathname-host (component-parent-pathname component))))) + +(defmethod component-pathname ((component component)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) + (merge-pathnames (component-relative-pathname component)))) + +(defgeneric component-property (component property)) + +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + +(defgeneric (setf component-property) (new-value component property)) + +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties)))))) + +(defclass system (module) + ((description :accessor system-description :initarg :description) + (long-description + :accessor system-long-description :initarg :long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence))) + +;;; version-satisfies + +;;; with apologies to christophe rhodes ... +(defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) + +(defgeneric version-satisfies (component version)) + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (return-from version-satisfies t)) + (let ((x (mapcar #'parse-integer + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding systems + +(defvar *defined-systems* (make-hash-table :test 'equal)) +(defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "~@" name)))) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* + '(sysdef-central-registry-search)) + +(defun system-definition-pathname (system) + (some (lambda (x) (funcall x system)) + *system-definition-search-functions*)) + +(defvar *central-registry* + '(*default-pathname-defaults* + #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" + #+nil "telent:asdf;systems;")) + +(defun sysdef-central-registry-search (system) + (let ((name (coerce-name system))) + (block nil + (dolist (dir *central-registry*) + (let* ((defaults (eval dir)) + (file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file))))))) + +(defun make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(defun find-system (name &optional (error-p t)) + (let* ((name (coerce-name name)) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. + on-disk + *package*) + (load on-disk)) + (delete-package package)))) + (let ((in-memory (gethash name *defined-systems*))) + (if in-memory + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) + +(defun register-system (name system) + (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (setf (gethash (coerce-name name) *defined-systems*) + (cons (get-universal-time) system))) + +(defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding components + +(defgeneric find-component (module name &optional version) + (:documentation "Finds the component with name NAME present in the +MODULE module; if MODULE is nil, then the component is assumed to be a +system.")) + +(defmethod find-component ((module module) name &optional version) + (if (slot-boundp module 'components) + (let ((m (find name (module-components module) + :test #'equal :key #'component-name))) + (if (and m (version-satisfies m version)) m)))) + + +;;; a component with no parent is a system +(defmethod find-component ((module (eql nil)) name &optional version) + (let ((m (find-system name nil))) + (if (and m (version-satisfies m version)) m))) + +;;; component subclasses + +(defclass source-file (component) ()) + +(defclass cl-source-file (source-file) ()) +(defclass c-source-file (source-file) ()) +(defclass java-source-file (source-file) ()) +(defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) ()) + +(defgeneric source-file-type (component system)) +(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") +(defmethod source-file-type ((c c-source-file) (s module)) "c") +(defmethod source-file-type ((c java-source-file) (s module)) "java") +(defmethod source-file-type ((c html-file) (s module)) "html") +(defmethod source-file-type ((c static-file) (s module)) nil) + +(defmethod component-relative-pathname ((component source-file)) + (let ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + name-type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; operations + +;;; one of these is instantiated whenever (operate ) is called + +(defclass operation () + ((forced :initform nil :initarg :force :accessor operation-forced) + (original-initargs :initform nil :initarg :original-initargs + :accessor operation-original-initargs) + (visited-nodes :initform nil :accessor operation-visited-nodes) + (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (parent :initform nil :initarg :parent :accessor operation-parent))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity t) + (ignore-errors + (prin1 (operation-original-initargs o) stream)))) + +(defmethod shared-initialize :after ((operation operation) slot-names + &key force + &allow-other-keys) + (declare (ignore slot-names force)) + ;; empty method to disable initarg validity checking + ) + +(defgeneric perform (operation component)) +(defgeneric operation-done-p (operation component)) +(defgeneric explain (operation component)) +(defgeneric output-files (operation component)) +(defgeneric input-files (operation component)) + +(defun node-for (o c) + (cons (class-name (class-of o)) c)) + +(defgeneric operation-ancestor (operation) + (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + +(defmethod operation-ancestor ((operation operation)) + (aif (operation-parent operation) + (operation-ancestor it) + operation)) + + +(defun make-sub-operation (c o dep-c dep-o) + (let* ((args (copy-list (operation-original-initargs o))) + (force-p (getf args :force))) + ;; note explicit comparison with T: any other non-NIL force value + ;; (e.g. :recursive) will pass through + (cond ((and (null (component-parent c)) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) + + +(defgeneric visit-component (operation component data)) + +(defmethod visit-component ((o operation) (c component) data) + (unless (component-visited-p o c) + (push (cons (node-for o c) data) + (operation-visited-nodes (operation-ancestor o))))) + +(defgeneric component-visited-p (operation component)) + +(defmethod component-visited-p ((o operation) (c component)) + (assoc (node-for o c) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) + +(defgeneric (setf visiting-component) (new-value operation component)) + +(defmethod (setf visiting-component) (new-value operation component) + ;; MCL complains about unused lexical variables + (declare (ignorable new-value operation component))) + +(defmethod (setf visiting-component) (new-value (o operation) (c component)) + (let ((node (node-for o c)) + (a (operation-ancestor o))) + (if new-value + (pushnew node (operation-visiting-nodes a) :test 'equal) + (setf (operation-visiting-nodes a) + (remove node (operation-visiting-nodes a) :test 'equal))))) + +(defgeneric component-visiting-p (operation component)) + +(defmethod component-visiting-p ((o operation) (c component)) + (let ((node (cons o c))) + (member node (operation-visiting-nodes (operation-ancestor o)) + :test 'equal))) + +(defgeneric component-depends-on (operation component)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (class-name (class-of o)) + (slot-value c 'in-order-to)))) + +(defgeneric component-self-dependencies (operation component)) + +(defmethod component-self-dependencies ((o operation) (c component)) + (let ((all-deps (component-depends-on o c))) + (remove-if-not (lambda (x) + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + +(defmethod input-files ((operation operation) (c component)) + (let ((parent (component-parent c)) + (self-deps (component-self-dependencies operation c))) + (if self-deps + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(defmethod input-files ((operation operation) (c module)) nil) + +(defmethod operation-done-p ((o operation) (c component)) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) + +;;; So you look at this code and think "why isn't it a bunch of +;;; methods". And the answer is, because standard method combination +;;; runs :before methods most->least-specific, which is back to front +;;; for our purposes. And CLISP doesn't have non-standard method +;;; combinations, so let's keep it simple and aspire to portability + +(defgeneric traverse (operation component)) +(defmethod traverse ((operation operation) (c component)) + (let ((forced nil)) + (labels ((do-one-dep (required-op required-c required-v) + (let* ((dep-c (or (find-component + (component-parent c) + ;; XXX tacky. really we should build the + ;; in-order-to slot with canonicalized + ;; names instead of coercing this late + (coerce-name required-c) required-v) + (error 'missing-dependency :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency :required-by c + :requires (car dep) :version nil))) + (t + (dolist (d dep) + (cond ((consp d) + (assert (string-equal + (symbol-name (first d)) + "VERSION")) + (appendf forced + (do-one-dep op (second d) (third d)))) + (t + (appendf forced (do-one-dep op d nil))))))))) + (aif (component-visited-p operation c) + (return-from traverse + (if (cdr it) (list (cons 'pruned-op c)) nil))) + ;; dependencies + (if (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) + (setf (visiting-component operation c) t) + (loop for (required-op . deps) in (component-depends-on operation c) + do (do-dep required-op deps)) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c)))))) + (setf (visiting-component operation c) nil) + (visit-component operation c (and forced t)) + forced))) + + +(defmethod perform ((operation operation) (c source-file)) + (sysdef-error + "~@" + (class-of operation) (class-of c))) + +(defmethod perform ((operation operation) (c module)) + nil) + +(defmethod explain ((operation operation) (component component)) + (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) + +;;; compile-op + +(defclass compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (on-warnings :initarg :on-warnings :accessor operation-on-warnings + :initform *compile-file-warnings-behaviour*) + (on-failure :initarg :on-failure :accessor operation-on-failure + :initform *compile-file-failure-behaviour*))) + +(defmethod perform :before ((operation compile-op) (c source-file)) + (map nil #'ensure-directories-exist (output-files operation c))) + +(defmethod perform :after ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (get-universal-time))) + +;;; perform is required to check output-files to find out where to put +;;; its answers, in case it has been overridden for site policy +(defmethod perform ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c)))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file source-file + :output-file output-file) + ;(declare (ignore output)) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation))))) + +(defmethod output-files ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #+:broken-fasl-loader (list (component-pathname c))) + +(defmethod perform ((operation compile-op) (c static-file)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + nil) + +;;; load-op + +(defclass load-op (operation) ()) + +(defmethod perform ((o load-op) (c cl-source-file)) + (mapcar #'load (input-files o c))) + +(defmethod perform ((operation load-op) (c static-file)) + nil) +(defmethod operation-done-p ((operation load-op) (c static-file)) + t) + +(defmethod output-files ((o operation) (c component)) + nil) + +(defmethod component-depends-on ((operation load-op) (c component)) + (cons (list 'compile-op (component-name c)) + (call-next-method))) + +;;; load-source-op + +(defclass load-source-op (operation) ()) + +(defmethod perform ((o load-source-op) (c cl-source-file)) + (let ((source (component-pathname c))) + (setf (component-property c 'last-loaded-as-source) + (and (load source) + (get-universal-time))))) + +(defmethod perform ((operation load-source-op) (c static-file)) + nil) + +(defmethod output-files ((operation load-source-op) (c component)) + nil) + +;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +(defmethod component-depends-on ((o load-source-op) (c component)) + (let ((what-would-load-op-do (cdr (assoc 'load-op + (slot-value c 'in-order-to))))) + (mapcar (lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) + what-would-load-op-do))) + +(defmethod operation-done-p ((o load-source-op) (c source-file)) + (if (or (not (component-property c 'last-loaded-as-source)) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) + nil t)) + +(defclass test-op (operation) ()) + +(defmethod perform ((operation test-op) (c component)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; invoking operations + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) + (let* ((op (apply #'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if verbose *trace-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) + +(defun oos (&rest args) + "Alias of OPERATE function" + (apply #'operate args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; syntax + +(defun remove-keyword (key arglist) + (labels ((aux (key arglist) + (cond ((null arglist) nil) + ((eq key (car arglist)) (cddr arglist)) + (t (cons (car arglist) (cons (cadr arglist) + (remove-keyword + key (cddr arglist)))))))) + (aux key arglist))) + +(defmacro defsystem (name &body options) + (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options + (let ((component-options (remove-keyword :class options))) + `(progn + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + (or ,pathname + (pathname-sans-name+type + (resolve-symlinks *load-truename*)) + *default-pathname-defaults*) + ',component-options)))))) + + +(defun class-for-type (parent type) + (let ((class + (find-class + (or (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) #.(package-name *package*))) + nil))) + (or class + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error "~@" type)))) + +(defun maybe-add-tree (tree op1 op2 c) + "Add the node C at /OP1/OP2 in TREE, unless it's there already. +Returns the new tree (which probably shares structure with the old one)" + (let ((first-op-tree (assoc op1 tree))) + (if first-op-tree + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + +(defun union-of-dependencies (&rest deps) + (let ((new-tree nil)) + (dolist (dep deps) + (dolist (op-tree dep) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + new-tree)) + + +(defun remove-keys (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(defvar *serial-depends-on*) + +(defun parse-component-form (parent options) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + + (check-component-input type name weakly-depends-on depends-on components in-order-to) + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) + (when (boundp '*serial-depends-on*) + (setf depends-on + (concatenate 'list *serial-depends-on* depends-on))) + (apply #'reinitialize-instance + ret + :name (coerce-name name) + :pathname pathname + :parent parent + other-args) + (when (typep ret 'module) + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop for c-form in components + for c = (parse-component-form ret c-form) + collect c + if serial + do (push (component-name c) *serial-depends-on*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) + + (setf (slot-value ret 'in-order-to) + (union-of-dependencies + in-order-to + `((compile-op (compile-op ,@depends-on)) + (load-op (load-op ,@depends-on)))) + (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) + + (loop for (n v) in `((perform ,perform) (explain ,explain) + (output-files ,output-files) + (operation-done-p ,operation-done-p)) + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) (remove-method (symbol-function n) m)) + (component-inline-methods ret)) + when v + do (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret)))) + ret))) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) + "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(defun sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) + +(defun resolve-symlinks (path) + #-allegro (truename path) + #+allegro (excl:pathname-resolve-symbolic-links path) + ) + +;;; optional extras + +;;; run-shell-command functions for other lisp implementations will be +;;; gratefully accepted, if they do the same thing. If the docstring +;;; is ambiguous, send a bug report + +(defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code." + (let ((command (apply #'format nil control-string args))) + (format *verbose-out* "; $ ~A~%" command) + #+sbcl + (sb-ext:process-exit-code + (sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + #+win32 #+win32 :search t + :input nil :output *verbose-out*)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+allegro + (excl:run-shell-command command :input nil :output *verbose-out*) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream *verbose-out*) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + )) + + +(defgeneric hyperdocumentation (package name doc-type)) +(defmethod hyperdocumentation ((package symbol) name doc-type) + (hyperdocumentation (find-package package) name doc-type)) + +(defun hyperdoc (name doc-type) + (hyperdocumentation (symbol-package name) name doc-type)) + + +(pushnew :asdf *features*) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") + (pushnew :sbcl-hooks-require *features*))) + +#+(and sbcl sbcl-hooks-require) +(progn + (defun module-provide-asdf (name) + (handler-bind ((style-warning #'muffle-warning)) + (let* ((*verbose-out* (make-broadcast-stream)) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)))) + + (defun contrib-sysdef-search (system) + (let* ((name (coerce-name system)) + (home (truename (sb-ext:posix-getenv "SBCL_HOME"))) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))) + + (pushnew + '(merge-pathnames "site-systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + *central-registry*) + + (pushnew + '(merge-pathnames ".sbcl/systems/" + (user-homedir-pathname)) + *central-registry*) + + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) + +(provide 'asdf) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\html.lisp corman\Modules\html.lisp --- corman3\Modules\html.lisp Tue Sep 05 09:43:54 2006 +++ corman\Modules\html.lisp Wed Dec 31 16:00:00 1969 @@ -1,174 +0,0 @@ -;;;; ------------------------------- -;;;; Copyright (c) Corman Technologies Inc. -;;;; All rights reserved. -;;;; ------------------------------- -;;;; -;;;; File: htmll.lisp -;;;; Contents: Functions which can be used to generate HTML pages. -;;;; History: 9/1/06 RGC Created. -;;;; -;;;; These functions were inspired by Paul Graham. -;;;; -(defpackage :html - (:export - "AS" - "WITH" - "WITH-TAGS" - "TAG" - "TEXT" - "DOCTYPE-HEADER" - "PAGE" - "
" - )) -(in-package :html) - -(defparameter *indent* 0) ;; starting indent level -(defparameter *indent-length* 2) ;; number spaces to indent HTML at each nesting level - -;;; -;;; The AS macro is useful where the body is a single string or several strings. -;;; Optional keyword/value pairs may proceed the body strings, and these will -;;; be inserted as parameters to the opening tag. The value may be a number or -;;; a string--if a number, it is converted to a string. -;;; It concatenates the body strings together. It will generate opening and -;;; closing tags. The output will be on separate lines, properly indented, unless -;;; the :embedded keyword is passed. If :embedded it true, then the output -;;; will be inserted into the current line, which is useful for short expressions -;;; and to keep the HTML succinct. -;;; -(defmacro as (tag &rest body) - (let ((args '()) - (embedded nil)) - (do () - ((not (keywordp (car body)))) - (if (eq (car body) ':embedded) - (setf embedded (cadr body)) - (progn - (push (car body) args) - (let ((value (cadr body))) - (if (numberp value) - (setq value (format nil "~A" value))) - (push value args)))) - (setf body (cddr body))) - (setq args (nreverse args)) - (if embedded - `(format t "<~A~{ ~A=\"~A\"~}>~A" ',tag (list ,@args) (concatenate 'string ,@body) ',tag) - `(let ((*indent* (+ *indent* *indent-length*))) - (format t "~v,0t<~A~{ ~A=\"~A\"~}>~A~%" - *indent* ',tag (list ,@args) (concatenate 'string ,@body) ',tag))))) - -;;; -;;; The WITH macro is useful where the body contains html which may have embedded tags. -;;; Optional keyword/value pairs may proceed the body expressions, and these will -;;; be inserted as parameters to the opening tag. The value may be a number or -;;; a string--if a number, it is converted to a string. -;;; The body expressions which follow any optional key/value pairs are expanded to -;;; generate retulting HTML, which is inserted between opening and closing tags. -;;; The output will be on separate lines, properly indented. -;;; The :embedded keyword (see AS) is not supported in WITH. -;;; -(defmacro with (tag &rest body) - (let ((args '()) - (single-line nil)) - (do () - ((not (keywordp (car body)))) - (if (eq (car body) ':single-line) - (setf single-line (cadr body)) - (progn - (push (car body) args) - (let ((value (cadr body))) - (if (numberp value) - (setq value (format nil "~A" value))) - (push value args)))) - (setf body (cddr body))) - (setq args (nreverse args)) - (if (find-if 'stringp body) - (setf body (mapcar (lambda (x) (if (stringp x) `(text ,x) x)) body))) - (if single-line - `(let ((*indent* (+ *indent* *indent-length*))) - (format t "~v,0t<~A~{ ~A=\"~A\"~}>" *indent* ',tag (list ,@args)) - ,@body - (format t "~%" ',tag)) - - `(let ((*indent* (+ *indent* *indent-length*))) - (format t "~v,0t<~A~{ ~A=\"~A\"~}>~%" *indent* ',tag (list ,@args)) - ,@body - (fresh-line) - (format t "~v,0t~%" *indent* ',tag))))) - -;;; -;;; The TAG macro is for tags (such as BR) which are complete (do not have closing tags) -;;; Args are optional, and would be in the form of keyword/value pairs which are -;;; used to add parameters to the generated tag. -;;; -(defmacro tag (tag &rest args) - (let ((outargs '()) - (embedded nil)) - (do () - ((not (keywordp (car args)))) - (if (eq (car args) ':embedded) - (setf embedded (cadr args)) - (progn - (push (car args) outargs) - (let ((value (cadr args))) - (if (numberp value) - (setq value (format nil "~A" value))) - (push value outargs)))) - (setf args (cddr args))) - (setq outargs (nreverse outargs)) - (if embedded - `(format t "<~A~{ ~A=\"~A\"~}/>" ',tag (list ,@outargs)) - `(let ((*indent* (+ *indent* *indent-length*))) - (format t "~v,0t<~A~{ ~A=\"~A\"~}/>~%" *indent* ',tag (list ,@outargs)))))) - -;;; -;;; Use the TEXT macro as a simple way to insert a series of one or more strings in a -;;; WITH macro. These are concatenated together. -;;; -(defmacro text (&rest body) - `(format t "~v,0t~A~%" *indent* (apply 'concatenate 'string (list ,@body)))) - -;;; -;;; Use WITH-TAGS to combine multiple tags into one form. -;;; Example use: -;;; (with-tags ((table :cols 1) tr td) (text "roger")) -;;; -generates- -;;; (with table :cols 1 (with tr (with td (text "roger")))) -;;; -which generates- -;;; -;;; -;;; -;;; -;;;
-;;; roger -;;;
-;;; -(defmacro with-tags ((&rest tags-and-params) &body body) - (let ((last-tag (car (last tags-and-params)))) - (if (and last-tag (symbolp last-tag)) - (setf last-tag (list last-tag))) - (if (null last-tag) - (car body) - `(with-tags ,(butlast tags-and-params) - (with ,@last-tag - ,@body))))) - -;;; -;;; Standard HTML DOCTYPE header. -;;; -(defmacro doctype-header () - `(format t "~A~%" "")) - -;;; -;;; The PAGE macro will cause the page to be expanded and output to a file. -;;; -(defmacro page (name &rest body) - `(with-open-file (*standard-output* - ,name - :direction :output - :if-exists :supersede) - ,@body)) - -(define-symbol-macro
(tag br)) - -(provide :html) \ No newline at end of file diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\macro-utilities.lisp corman\Modules\macro-utilities.lisp --- corman3\Modules\macro-utilities.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\macro-utilities.lisp Tue Feb 14 10:34:41 2006 @@ -0,0 +1,40 @@ +(in-package :cl-user) + +(defpackage "COM.GIGAMONKEYS.MACRO-UTILITIES" + (:nicknames "MACRO-UTILITIES") + (:use "CL") + (:export + "WITH-GENSYMS" + "WITH-GENSYMED-DEFUNS" + "ONCE-ONLY" + "SPLICEABLE" + "PPME")) + +(in-package "COM.GIGAMONKEYS.MACRO-UTILITIES") + +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym (string n))))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun spliceable (value) + (if value (list value))) + +(defmacro ppme (form &environment env) + (progn + (write (macroexpand-1 form env) + :length nil + :level nil + :circle nil + :pretty t + :gensym nil + :right-margin 83 + :case :downcase) + nil)) + diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\misc-ansi.lisp corman\Modules\misc-ansi.lisp --- corman3\Modules\misc-ansi.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\misc-ansi.lisp Fri Oct 21 10:01:00 2005 @@ -0,0 +1,102 @@ +;;;; Implementation of various ANSI bits missing from Corman Lisp - Version 1.1 +;;;; +;;;; Copyright (C) 2004 Espen Wiborg. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +(in-package :common-lisp) + +(require 'winbase) + +(defun get-standard-pprint-dispatch-table () + (xp::make-pprint-dispatch)) + +(defun get-standard-readtable () + *common-lisp-readtable*) + +(export '(get-standard-pprint-dispatch-table get-standard-readtable) + "COMMON-LISP") + +;; Cop-out implementation +(defun machine-instance () + nil) + +;; +;; Need these as well +;; Thanks to Andy Sloane +(defun machine-version () + nil) + +(defun machine-type () + nil) + +(defun user-homedir-pathname (&optional host) + (flet ((getenv (name) + (let ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string name))) + (let* ((needed-size (win:getenvironmentvariable + cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable + cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1)))))) + (cond ((or (stringp host) + (and (consp host) + (every #'stringp host))) + nil) + ((or (eq host :unspecific) + (null host)) + (let ((homedrive (getenv "HOMEDRIVE")) + (homepath (getenv "HOMEPATH"))) + (parse-namestring + (if (and (stringp homedrive) + (stringp homepath) + (= (length homedrive) 2) + (> (length homepath) 0)) + (concatenate 'string homedrive homepath) + "C:\\")))) + (t + (error "HOST must be a string, list of strings, NIL or :UNSPECIFIC"))))) + +(defun wild-pathname-p (pathname &optional field-key) + (let ((obj (ecase field-key + ((nil) (namestring pathname)) + ((:host) (pathname-host pathname)) + ((:device) (pathname-device pathname)) + ((:directory) (pathname-directory pathname)) + ((:name) (pathname-name pathname)) + ((:type) (pathname-type pathname)) + ((:version) (pathname-version pathname))))) + (flet ((wild-p (sym) (or (eq sym :wild) + (eq sym :wild-inferiors)))) + (etypecase obj + (symbol (wild-p obj)) + (list (position-if (lambda (o) (typecase o + (symbol (wild-p o)) + (string (string= obj "*")))) + obj)) + (string (position #\* obj :test #'char=)))))) + +(provide "MISC-ANSI") diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\sockets.lisp corman\Modules\sockets.lisp --- corman3\Modules\sockets.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\sockets.lisp Fri Feb 03 17:53:44 2006 @@ -0,0 +1,1044 @@ +;;;; Simple socket library for Corman Lisp - Version 1.9 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; See the examples at the end of the file for useage. It requires +;;;; at least version 1.4 of Corman Lisp available at http://www.cormanlisp.com +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris@double.co.nz +;;;; +;;;; 05/12/1999 - 1.0 +;;;; Initial release. +;;;; It's quite rough and quickly thrown together but does +;;;; allow using sockets with Corman Lisp 1.3. The API needs +;;;; work and I'm open to suggestions on better ways of doing +;;;; things. Stream integration would be nice. The intent of +;;;; the software was purely an example of using the +;;;; WINSOCK API but it may prove useful outside of that. +;;;; +;;;; 06/12/1999 - 1.1 +;;;; Added exports to package definition. +;;;; Removed INTERNET-ADDRESS class and associated generic +;;;; functions, replacing with IPADDR-TO-NAME, and similar +;;;; functions working on the ipaddr directly. +;;;; HOST-TO-IPADDR can now take host name or dotted address. +;;;; Added example of a server in a thread. +;;;; +;;;; 18/12/1999 - 1.2 +;;;; Changed finalization registration of socket class to +;;;; call CLOSE-SOCKET on the object passed to the finalization +;;;; function rather than the closure over the argument to the +;;;; INITIALIZE-INSTANCE method. +;;;; Changed READ-SOCKET-LINE to have the similar arguments and eof +;;;; behaviour as READ-LINE. +;;;; Added a buffer to READ-SOCKET-LINE to remove the previous +;;;; behavior of 1 byte reads. +;;;; Added DO-FFI-READ-SOCKET generic function to enable sharing +;;;; of READ-SOCKET-LINE code between SSL sockets and standard sockets. +;;;; Ditto with DO-FFI-WRITE-SOCKET. +;;;; Moved to a simpler license. +;;;; Added WITH-CLIENT-SOCKET, WITH-SERVER-SOCKET, +;;;; WITH-SERVER-ACCEPT and START-SOCKET-SERVER. +;;;; +;;;; 19/12/1999 - 1.3 +;;;; Added READ-SOCKET and WRITE-SOCKET. Added example using these +;;;; methods. +;;;; +;;;; 02/03/2000 - 1.4 +;;;; Updated for Corman Lisp 1.4. The changes were to add the +;;;; require for the winsock package, various ignore delcarations +;;;; and use provide with the name SOCKETS. By putting this file in +;;;; the modules subdirectory of your corman lisp implementation you +;;;; can load it automatically using (require 'SOCKETS). +;;;; A future update will improve the error handling with the new +;;;; features available in Corman Lisp 1.4. +;;;; +;;;; 30/08/2000 - 1.5 +;;;; Added support for socket streams. Calling MAKE-SOCKET-STREAM on +;;;; a socket will return a stream that can be used with the standard +;;;; common lisp functions like READ-LINE, etc. The stream is buffered +;;;; for both reads and writes, so when writing you will need to use +;;;; FORCE-OUTPUT on the stream to send the data over the socket. +;;;; +;;;; I also improved the code that handles the read buffer for sockets. +;;;; The stream integration requires some modifications to some standard +;;;; common lisp functions (READ-LINE, WRITE-LINE, CLOSE). These are +;;;; overridden and the original functions called when the network required +;;;; portion is performed. For example, CLOSE can be used on the socket +;;;; stream as a result of this. +;;;; +;;;; When creating a socket stream, don't use the original socket otherwise +;;;; the buffering will get confused. The stream and socket use seperate +;;;; buffers. I'll probably fix this some day. +;;;; +;;;; Some new examples have been added to show stream use. +;;;; +;;;; Added a WINSOCK-ERROR condition for when errors occur. Added +;;;; READ-SOCKET-CHAR. Added convenience macro, WITH-SOCKET-STREAM to create +;;;; a stream for a socket and close it at the end of the macro scope. +;;;; +;;;; 05/08/2000 - 1.6 +;;;; Added support for using client sockets by tunnelling +;;;; through a proxy server. Currently only 'generic' +;;;; proxy support is implemented. That is, servers that +;;;; provide socket and SSL tunnelling via the CONNECT +;;;; method. I also haven't implemented authentication +;;;; (if the proxy requires you to logon). It does work +;;;; for the generic proxy I use and has been tested with +;;;; port 443 (SSL) and port 80 (Standard HTTP). See the +;;;; examples at the end of the file for an example of +;;;; how to use a proxy (hint: set *DEFAULT-PROXY-SERVER* +;;;; to be an instance of GENERIC-PROXY-SERVER containing +;;;; your proxy details). The proxy functionality is +;;;; experimental and will probably change as I add +;;;; authentication and other support. +;;;; +;;;; Added WITH-SOCKETS-STARTED macro to call +;;;; START-SOCKETS and STOP-SOCKETS around the supplied +;;;; body. +;;;; +;;;; Fixed problem in POPULATE-SOCKET-READ-BUFFER that +;;;; could cause blocking on a socket even though data +;;;; had already been loaded in the buffer that the +;;;; caller could use. +;;;; +;;;; Uncovered a bug in READ-SEQUENCE in Corman Lisp 1.41 +;;;; that causes one too many bytes to be read causing +;;;; blocking sockets when reading sequences. Unless you +;;;; have patched CL 1.41 to fix this problem I suggest +;;;; not using READ-SEQUENCE (See +;;;; http://www.double.co.nz/cl) for an unofficial patch +;;;; to READ-SEQUENCE to fix the problem. +;;;; +;;;; 10/08/2000 - 1.7 +;;;; Added REMOTE-SOCKET-IPADDR to REMOTE-SOCKET to allow +;;;; retrieval of the IP address of the remote machine. +;;;; +;;;; 16/08/2000 - 1.8 +;;;; Added WITH-THREADED-SERVER-ACCEPT and +;;;; START-THREADED-SOCKET-SERVER which spawn a new thread +;;;; to process the remote socket. Increased the buffer size +;;;; of sockets for better performance. Changed +;;;; SOCKET-STREAM-OVERFLOW-FUNCTION to check to see if the full +;;;; buffer is being sent, and if so, don't copy the contents to +;;;; a temporary buffer. This is the most common case and improves +;;;; write performance quite a bit. +;;;; Changed the way DO-FFI-WRITE-SOCKET worked. It now explicitly +;;;; allocates a C buffer rather than relying on automatic string +;;;; conversion between lisp/c types. This stops a memory corruption +;;;; that was occuring. +;;;; Automatically calls START-SOCKETS when loaded. +;;;; +;;;; 17/08/2000 - 1.9 +;;;; Changed the redefinition of CLOSE to close SOCKETS as well as +;;;; streams. +;;;; +(require 'WINSOCK) + +(defpackage "SOCKETS" + (:use + :COMMON-LISP + :WIN + :C-TYPES + :WINSOCK) + (:export + "START-SOCKETS" + "STOP-SOCKETS" + "WITH-SOCKETS-STARTED" + "HOST-TO-IPADDR" + "IPADDR-TO-NAME" + "IPADDR-TO-DOTTED" + "BASE-SOCKET" + "SOCKET-DESCRIPTOR" + "REMOTE-SOCKET" + "PROXY-SOCKET-MIXIN" + "PROXY-CLIENT-SOCKET" + "PROXY-INITIALIZED" + "*DEFAULT-PROXY-SERVER*" + "PROXY-SERVER" + "GENERIC-PROXY-SERVER" + "PROXY-SERVER-HOST" + "PROXY-SERVER-PORT" + "LOCAL-SOCKET" + "SOCKET-HOST" + "SOCKET-PORT" + "CLIENT-SOCKET" + "SERVER-SOCKET" + "ACCEPT-SOCKET" + "CLOSE-SOCKET" + "WRITE-SOCKET-LINE" + "DO-FFI-READ-SOCKET" + "DO-FFI-WRITE-SOCKET" + "READ-SOCKET-LINE" + "READ-SOCKET" + "READ-SOCKET-CHAR" + "WRITE-SOCKET" + "MAKE-CLIENT-SOCKET" + "MAKE-SERVER-SOCKET" + "WITH-CLIENT-SOCKET" + "WITH-SERVER-SOCKET" + "WITH-SERVER-ACCEPT" + "WITH-THREADED-SERVER-ACCEPT" + "START-SOCKET-SERVER" + "START-THREADED-SOCKET-SERVER" + "MAKE-SOCKET-STREAM" + "WITH-SOCKET-STREAM" + "STREAM-SOCKET-HANDLE" + "REMOTE-SOCKET-CLASS" + "REMOTE-SOCKET-IPADDR" + )) + +(in-package :sockets) + +(defmacro with-c-buffer ((buffer length) &body body) + "Helper macro to automatically free a malloced buffer." + `(let ((,buffer (malloc ,length))) + (unwind-protect + (progn + ,@body) + (free ,buffer)))) + +(defparameter *socket-buffer-length* 20000 + "Size of buffer used to read data from the socket stream.") + +(defun make-word ( low-byte high-byte ) + (logior (logand low-byte #xff) (ash (logand high-byte #xff) 8))) + +(define-condition winsock-error (error) + ((original-error-code :initarg :original-error-code :initform nil :reader winsock-original-error-code) + (last-error-code :initarg :last-error-code :initform nil :reader winsock-last-error-code)) + (:report (lambda (condition stream) + (format stream "Winsock error number ~A (WSALastError=~A)." + (winsock-original-error-code condition) + (winsock-last-error-code condition))))) + +(defun handle-winsock-error (&optional original-code) + "Handle the result of a winsock function returning an error value." + (format t "Winsock Error~%") + (force-output) + (cerror "Winsock Error" + 'winsock-error + :original-error-code original-code + :last-error-code (WSAGetLastError))) + +(defun default-winsock-error-test (x) + "Tests against the standard 0 success code." + (not (= x 0))) + +(defmacro with-winsock-error-handling ((&key (error-test #'default-winsock-error-test)) winsock-call &body body) + (let ((result-code (gensym))) + `(let ((,result-code ,winsock-call)) + (if (funcall ,error-test ,result-code) + (handle-winsock-error ,result-code) + (progn ,result-code ,@body))))) + +(defmacro with-invalid-socket-check (() winsock-call &body body) + "Checks the result of the winsock call and signals an error if it + is an INVALID_SOCKET. Otherwise processes the body forms." + (declare (ignore nil)) + `(with-winsock-error-handling + (:error-test #'(lambda (x) (= x INVALID_SOCKET))) + ,winsock-call + ,@body)) + +(defmacro with-socket-error-check (() winsock-call &body body) + "Checks the result of the winsock call and signals an error if it + is a SOCKET_ERROR. Otherwise processes the body forms." + (declare (ignore nil)) + `(with-winsock-error-handling + (:error-test #'(lambda (x) (= x SOCKET_ERROR))) + ,winsock-call + ,@body)) + +(defmacro with-winsock-pointer-expected (() winsock-call &body body) + "Checks that the result of the winsock call is a non-null pointer. + If it is null, then raises an error and does not process the body + of the macro." + (declare (ignore nil)) + (let ((pointer-result (gensym))) + `(let ((,pointer-result ,winsock-call)) + (if (cpointer-null ,pointer-result) + (handle-winsock-error) + (progn ,pointer-result ,@body))))) + +(defvar *sockets-started* nil + "Set to T when START-SOCKETS is called.") + +(defun start-sockets () + "Initialize the winsock libraries." + (unless *sockets-started* + (with-fresh-foreign-block (wsa 'WSADATA) + (with-winsock-error-handling () + (WSAStartup (make-word 1 1) wsa))) + (setq *sockets-started* t))) + +(defun stop-sockets () + "Shutdown the winsock libraries." + (when *sockets-started* + (with-winsock-error-handling () + (WSACleanup)) + (setq *sockets-started* nil))) + +(defmacro with-sockets-started (&body body) + "Helper macro to automatically start and stop sockets." + `(progn + (start-sockets) + (unwind-protect + (progn + ,@body) + (stop-sockets)))) + +(defun host-to-ipaddr (dotted-or-name) + "Return the ipaddr given a host name or dotted IP address." + (let* ((name (lisp-string-to-c-string dotted-or-name)) + (ipaddr (inet_addr name))) + (when (and (= ipaddr INADDR_NONE) + (not (equal dotted-or-name "255.255.255.255"))) + (setq ipaddr + (let* ((he (with-winsock-pointer-expected () + (gethostbyname name))) + (addr-list (cref hostent he winsock::h_addr_list)) + (addr0 (cref ((:unsigned-long *) *) addr-list 0))) + (cref (:unsigned-long *) addr0 0)))) + ipaddr)) + +(defun ipaddr-to-name (ipaddr) + "Given an ipaddr, lookup the host name" + (with-fresh-foreign-block (temp-ipaddr :unsigned-long) + (setf (cref (:unsigned-long *) temp-ipaddr 0) ipaddr) + (c-string-to-lisp-string + (cref hostent + (with-winsock-pointer-expected () + (gethostbyaddr temp-ipaddr (sizeof :unsigned-long) AF_INET)) + winsock::h_name)))) + + +(defun ipaddr-to-dotted (ipaddr) + "Given ipaddr, return the dotted name." + (c-string-to-lisp-string + (with-winsock-pointer-expected () + (inet_ntoa (int-to-foreign-ptr ipaddr))))) + +(defclass base-socket () + ((socket-descriptor + :initform nil + :initarg :descriptor + :accessor socket-descriptor) + (read-buffer :initform nil :accessor socket-read-buffer) + (read-complete :initform nil :accessor socket-read-complete)) + (:documentation + "On finalization the socket will be closed if CLOSE-SOCKET + has not already been called.")) + +(defclass remote-socket (base-socket) + ((address :initform nil :initarg :address :accessor remote-socket-ipaddr)) + (:documentation + "The socket returned by an ACCEPT-SOCKET call. This socket is + used to communicate with the remote host.")) + +(defclass local-socket (base-socket) + ((host-ipaddr :initform nil :accessor socket-host-ipaddr) + (port :initform nil :accessor socket-port)) + (:documentation + "Base class for sockets that are created and used on the client machine. + Takes the keywords :HOST and :PORT on creation of the instance. :HOST can + be a hostname or dotted ip address.")) + +(defclass client-socket (local-socket) () + (:documentation + "Socket used for client programming.")) + +(defclass server-socket (local-socket) () + (:documentation + "Socket used for writing servers. Allows calling of ACCEPT-SOCKET and returning + of the remote-socket for communicating with the incoming connection.")) + +(defvar *default-proxy-server* nil) + +(defclass proxy-server () + ((host :initform nil :initarg :host :accessor proxy-server-host) + (port :initform nil :initarg :port :accessor proxy-server-port)) + (:documentation + "Base class for holding proxy server information. Derived classes + should exist to implement the protocol specific to the type of + proxy server.")) + +(defclass generic-proxy-server (proxy-server) + () + (:documentation + "Implements the proxy server protocol for those proxy servers that + support tunnelling via the CONNECT method.")) + +(defgeneric proxy-server-connect (server socket host port)) + +(defmethod proxy-server-connect ((server generic-proxy-server) s host port) + (declare (ignore server)) + (write-socket-line s + (format nil "CONNECT ~A:~A HTTP/1.0" host port)) + (write-socket-line s "") + (read-socket-line s) ;; Verify here? + (loop as line = (read-socket-line s) + until (= (length line) 0))) + +(defclass proxy-socket-mixin () + ((initialized :initform nil :accessor proxy-initialized)) + (:documentation + "Class to mixin with other socket classes to provide the ability + to work through a proxy server.")) + +(defclass proxy-client-socket (client-socket proxy-socket-mixin) + () + (:documentation + "A standard socket that is used through a proxy server.")) + +(defmethod initialize-instance :after ((s base-socket) &allow-other-keys) + (ccl:register-finalization s #'(lambda (x) (close-socket x)))) + +(defmethod initialize-instance ((s local-socket) &key host port &allow-other-keys) + (call-next-method) + (setf (socket-host-ipaddr s) (host-to-ipaddr host)) + (setf (socket-port s) (or port 0)) + (setf (socket-descriptor s) + (with-invalid-socket-check () + (socket AF_INET SOCK_STREAM 0)))) + +(defmethod initialize-instance :after ((s local-socket) &allow-other-keys) + (with-fresh-foreign-block (sin-local 'sockaddr_in) + (with-fresh-foreign-block (size 'int) + (setf (cref (int *) size 0) (sizeof 'sockaddr_in)) + (with-socket-error-check () + (getsockname (socket-descriptor s) sin-local size) + (setf (socket-port s) + (ntohs (cref sockaddr_in sin-local winsock::sin_port))))))) + +(defmethod initialize-instance ((s client-socket) &key host port &allow-other-keys) + (declare (ignore port host)) + (call-next-method) + (with-fresh-foreign-block (sin-remote 'sockaddr_in) + (setf (cref sockaddr_in sin-remote winsock::sin_family) AF_INET) + (let ((sin0 (cref sockaddr_in sin-remote winsock::sin_addr))) + (setf (cref in_addr sin0 winsock::S_addr) (socket-host-ipaddr s)) + (setf (cref sockaddr_in sin-remote winsock::sin_port) (htons (socket-port s))) + (with-socket-error-check () + (connect (socket-descriptor s) sin-remote (sizeof 'sockaddr_in)))))) + +(defmethod initialize-instance ((s server-socket) &key host port &allow-other-keys) + (declare (ignore port host)) + (call-next-method) + (with-fresh-foreign-block (sin-local 'sockaddr_in) + (setf (cref sockaddr_in sin-local winsock::sin_family) AF_INET) + (let ((sin0 (cref sockaddr_in sin-local winsock::sin_addr))) + (setf (cref in_addr sin0 winsock::S_addr) (socket-host-ipaddr s))) + (setf (cref sockaddr_in sin-local winsock::sin_port) (htons (socket-port s))) + (with-socket-error-check () + (bind (socket-descriptor s) sin-local (sizeof 'sockaddr_in))) + (with-socket-error-check () + (listen (socket-descriptor s) SOMAXCONN)))) + +(defmethod initialize-instance :after ((s proxy-socket-mixin) &key real-host real-port proxy &allow-other-keys) + (proxy-server-connect proxy s real-host real-port) + (setf (proxy-initialized s) t)) + +(defgeneric remote-socket-class (s) + (:documentation "Given a server socket, return the class + used for the remote socket for that server socket type.")) + +(defmethod remote-socket-class ((s server-socket)) + (declare (ignore s)) + 'remote-socket) + +(defgeneric accept-socket (s) + (:documentation + "Block until a connection is received on the port for this server + socket. When a connection is received, return a REMOTE-SOCKET for + communicating with the remote host.")) + +(defmethod accept-socket ((s server-socket)) + (with-fresh-foreign-block (sin-remote 'sockaddr_in) + (with-fresh-foreign-block (size-addr 'long) + (setf (cref (:unsigned-long *) size-addr 0) (sizeof 'sockaddr_in)) + (let ((as (with-invalid-socket-check () + (accept (socket-descriptor s) sin-remote size-addr)))) + (make-instance (remote-socket-class s) + :descriptor as + :address (cref (:unsigned-long *)sin-remote 1)))))) + +(defgeneric close-socket (s) + (:documentation + "Close the socket connection. This function does not need + to be called explicitly as it will be called during finalization of the + object if required.")) + +(defmethod close-socket ((s base-socket)) + (let ((descriptor (socket-descriptor s))) + (when descriptor + (shutdown descriptor 1) + (with-c-buffer (buffer (+ 1 *socket-buffer-length*)) + (loop + (let ((result (recv descriptor buffer *socket-buffer-length* 0))) + (when (or (= result SOCKET_ERROR) (= result 0)) + (return))))) + (closesocket descriptor) + (setf (socket-descriptor s) nil)))) + +(defgeneric do-ffi-write-socket (s buffer length) + (:documentation + "Perform FFI function to write socket data. Extracted out to allow sharing + of commonality between standard sockets and SSL sockets. BUFFER should be + a C buffer.")) + +(defmethod do-ffi-write-socket ((s base-socket) buffer length) + (with-c-buffer (c-buffer (+ length 1)) + (dotimes (n length) + (setf (ct:cref (:unsigned-char *) c-buffer n) (char-int (elt buffer n)))) + (with-socket-error-check () + (send (socket-descriptor s) c-buffer length 0)))) + +(defmethod do-ffi-write-socket :around ((s proxy-socket-mixin) buffer length) + (if (proxy-initialized s) + (call-next-method) + (with-c-buffer (c-buffer (+ length 1)) + (dotimes (n length) + (setf (ct:cref (:unsigned-char *) c-buffer n) (char-int (elt buffer n)))) + (with-socket-error-check () + (send (socket-descriptor s) c-buffer length 0))))) + +(defgeneric write-socket (s string) + (:documentation + "Send a string of bytes across the socket.")) + +(defmethod write-socket ((s base-socket) string) + (do-ffi-write-socket s string (length string))) + +(defgeneric write-socket-line (s string) + (:documentation + "Send a string across the socket, terminating with a carriage + return and line feed.")) + +(defmethod write-socket-line ((s base-socket) line) + (let* ((line-buffer (concatenate 'string line (list #\Return #\Newline))) + (line-length (length line-buffer))) + (do-ffi-write-socket s line-buffer line-length))) + +(defgeneric read-socket (s length &optional eof-error-p eof-value) + (:documentation + "Read a number of bytes from the socket and return as a string.")) + +(defgeneric read-socket-char (s &optional eof-error-p eof-value) + (:documentation + "Read a single character from the socket and return it.")) + +(defmethod read-socket ((s base-socket) len &optional eof-error-p eof-value) + (declare (ignore eof-error-p)) + (when (< (length (socket-read-buffer s)) len) + (populate-socket-read-buffer s + :block t + :len (- len (length (socket-read-buffer s))))) + (if (zerop (length (socket-read-buffer s))) + eof-value + (let ((len (min len (length (socket-read-buffer s))))) + (prog1 + (subseq (socket-read-buffer s) 0 len) + (setf (socket-read-buffer s) + (subseq + (socket-read-buffer s) len)))))) + +(defmethod read-socket-char ((s base-socket) &optional eof-error-p eof-value) + (declare (ignore eof-error-p)) + (when (< (length (socket-read-buffer s)) 1) + (populate-socket-read-buffer s + :block t + :len 1)) + (if (zerop (length (socket-read-buffer s))) + eof-value + (prog1 + (elt (socket-read-buffer s) 0) + (setf (socket-read-buffer s) + (subseq + (socket-read-buffer s) 1))))) + +(defun socket-data-available (s) + "Return the number of bytes available to be read on + the socket without blocking." + (with-fresh-foreign-block (argp 'ULONG) + (setf (cref (:unsigned-long *) argp 0) 0) + (ioctlsocket (socket-descriptor s) 1074030207 argp) + (cref (:unsigned-long *) argp 0))) + +(defun c-buffer-to-string (buffer bytes) + "Create a lisp string from the BYTES first bytes of BUFFER. +BUFFER may contain null bytes." + (coerce (loop for i below bytes + collect (code-char (cref (:unsigned-char *) buffer i))) + 'string)) + +(defun populate-socket-read-buffer (s &key block len) + "Fill the socket read buffer with data from the socket. + Attempt to read at least LEN bytes into the buffer. The + function will block waiting for data if BLOCK is T. If + LEN is not supplied, read as much data is available from + the socket without blocking." + (when (and (> (length (socket-read-buffer s)) 0) + (or (null len) + (<= len (length (socket-read-buffer s))))) + (return-from populate-socket-read-buffer)) + (with-c-buffer (buffer (+ *socket-buffer-length* 1)) + (loop + (let ((bytes (do-ffi-read-socket s buffer *socket-buffer-length*))) + (when (<= bytes 0) + (setf (socket-read-complete s) t) + (return)) + (setf (socket-read-buffer s) + (concatenate 'string + (socket-read-buffer s) + (c-buffer-to-string buffer bytes))) + (when (and len (<= (decf len bytes) 0)) + (return)) + (when (and (not block) (zerop (socket-data-available s))) + (return)))))) + +(defgeneric read-socket-line (s &optional eof-error-p eof-value) + (:documentation + "Read a line of text data from the socket and return as a string.")) + +(defgeneric do-ffi-read-socket (s buffer length) + (:documentation + "Perform FFI function to read socket. Extracted out to allow sharing + of commonality between standard sockets and SSL sockets.")) + +(defmethod do-ffi-read-socket ((s base-socket) buffer length) + (with-socket-error-check () + (recv (socket-descriptor s) buffer length 0))) + +(defmethod do-ffi-read-socket :around ((s proxy-socket-mixin) buffer length) + (if (proxy-initialized s) + (call-next-method) + (with-socket-error-check () + (recv (socket-descriptor s) buffer length 0)))) + +;; Much of the READ-SOCKET-LINE code is based on READ-LINE from the Corman +;; Lisp implementation. +(defmethod read-socket-line ((s base-socket) &optional eof-error-p eof-value) + (declare (ignore eof-error-p)) + (let ((str (make-array 256 :element-type 'character :fill-pointer t))) + (setf (fill-pointer str) 0) + (do ((ch (read-socket-char s nil :eof) (read-socket-char s nil :eof))) + ((and (not (eq ch :eof)) (eql ch #\Newline)) (concatenate 'string str)) + (if (eq ch :eof) + (if (> (length str) 0) + (return-from read-socket-line (concatenate 'string str)) + (return-from read-socket-line eof-value))) + (when (not (eql ch #\Return)) + (vector-push-extend ch str))))) + +(defun make-client-socket (&key host port (proxy *default-proxy-server*)) + "Create and return a client socket attached to the HOST and PORT." + (if proxy + (make-instance 'proxy-client-socket + :host (proxy-server-host proxy) + :port (proxy-server-port proxy) + :real-host host + :real-port port + :proxy proxy) + (progn + (make-instance 'client-socket :host host :port port)))) + +(defun make-server-socket (&key host port) + "Create and return a sever socket listening on the HOST and PORT." + (make-instance 'server-socket :host host :port port)) + +(defmacro with-client-socket ((socket &key host port proxy) &body body) + "Ensures that the SOCKET is closed when scope of WITH-CLIENT-SOCKET + has ended." + (let ((p-name (gensym))) + `(let* ((,p-name (if ,proxy ,proxy *default-proxy-server*)) + (,socket (make-client-socket :host ,host :port ,port :proxy ,p-name))) + (unwind-protect + (progn + ,@body) + (close-socket ,socket))))) + +(defmacro with-server-socket ((socket &key host port) &body body) + "Ensures that the SOCKET is closed when scope of WITH-SERVER-SOCKET + has ended." + `(let ((,socket (make-server-socket :host ,host :port ,port))) + (unwind-protect + (progn + ,@body) + (close-socket ,socket)))) + +(defmacro with-server-accept ((remote-socket server-socket) &body body) + "Ensures that the REMOTE-SOCKET is closed when scope of WITH-REMOTE-SOCKET + has ended." + `(let ((,remote-socket (accept-socket ,server-socket))) + (unwind-protect + (progn + ,@body) + (close-socket ,remote-socket)))) + +(defmacro with-threaded-server-accept ((remote-socket server-socket) &body body) + "Ensures that the REMOTE-SOCKET is closed when scope of WITH-REMOTE-SOCKET + has ended." + `(let ((,remote-socket (accept-socket ,server-socket))) + (th:create-thread #'(lambda () + (unwind-protect + (progn + ,@body) + (close-socket ,remote-socket)))))) + +(defmacro start-socket-server ((server-socket remote-socket) &body body) + "Starts an ACCEPT-SOCKET loop, and evaluates the BODY with the + REMOTE-SOCKET bound to the result of the ACCEPT-SOCKET call. The loop + continues indefinitely or until a RETURN expression." + `(loop + (with-server-accept (,remote-socket ,server-socket) + ,@body))) + +(defmacro start-threaded-socket-server ((server-socket remote-socket) &body body) + "Starts an ACCEPT-SOCKET loop, and evaluates the BODY with the + REMOTE-SOCKET bound to the result of the ACCEPT-SOCKET call. The loop + continues indefinitely or until a RETURN expression." + `(loop + (with-threaded-server-accept (,remote-socket ,server-socket) + ,@body))) + +;; Rather hacked together stream integration. Results in two buffers +;; being kept for the socket. One held by the socket itself, the other +;; held by the stream. Need to re-think how to do this but I wanted +;; something quickly... +(defun socket-stream-underflow-function (s) + "Function that gets called by the Corman Lisp stream functions when + the stream buffer is exhausted." + (let* ((buffer (cl::stream-input-buffer s)) + (socket (cl::stream-handle s))) + (populate-socket-read-buffer socket :block nil) + (let* ((socket-buffer (socket-read-buffer socket)) + (real-length (min (length socket-buffer) + (cl::stream-input-buffer-length s)))) + (dotimes (i real-length) + (setf (elt buffer i) (elt socket-buffer i))) + (setf (cl::stream-input-buffer-pos s) 0) + (setf (cl::stream-input-buffer-num s) real-length) + (setf (socket-read-buffer socket) + (subseq (socket-read-buffer socket) real-length))))) + +(defun socket-stream-overflow-function (s) + "Called by the Corman Lisp library when the stream output buffer + is full." + (let* ((buffer (cl::stream-output-buffer s)) + (buffer-length (cl::stream-output-buffer-pos s)) + (socket (cl::stream-handle s))) + (if (= buffer-length (cl::stream-output-buffer-length s)) + (write-socket socket buffer) + (let ((new-buffer (make-string buffer-length))) + (do ((i 0 (+ i 1)) + (j 0 (+ j 1))) + ((= i buffer-length)) + (setf (char new-buffer j) (char buffer i))) + (write-socket socket new-buffer))) + (setf (cl::stream-output-buffer-pos s) 0))) + +(defun make-socket-stream (s) + "Given a socket return a stream that allows reads and writes + to that socket." + (let ((stream (cl::alloc-uvector cl::stream-size cl::uvector-stream-tag))) + (setf (cl::uref stream cl::stream-name-offset) nil) + (setf (cl::uref stream cl::stream-subclass-offset) 'socket-stream) + (setf (cl::uref stream cl::stream-underflow-func-offset) #'socket-stream-underflow-function) + (setf (cl::uref stream cl::stream-overflow-func-offset) #'socket-stream-overflow-function) + (setf (cl::uref stream cl::stream-position-offset) 0) + (setf (cl::uref stream cl::stream-col-position-offset) 0) + (setf (cl::uref stream cl::stream-handle-offset) s) + (setf (cl::uref stream cl::stream-binary-offset) nil) + (setf (cl::uref stream cl::stream-line-number-offset) 0) + (setf (cl::uref stream cl::stream-open-offset) t) + (setf (cl::uref stream cl::stream-direction-offset) :bidirectional) + (setf (cl::uref stream cl::stream-interactive-offset) nil) + (setf (cl::uref stream cl::stream-element-type-offset) 'character) + (setf (cl::uref stream cl::stream-associated-streams-offset) nil) + (setf (cl::uref stream cl::stream-output-buffer-offset) (make-array (+ *socket-buffer-length* 0) :element-type 'character)) + (setf (cl::uref stream cl::stream-output-buffer-length-offset) *socket-buffer-length*) + (setf (cl::uref stream cl::stream-output-buffer-pos-offset) 0) + (setf (cl::uref stream cl::stream-input-buffer-offset) (make-array *socket-buffer-length* :element-type 'character)) + (setf (cl::uref stream cl::stream-input-buffer-length-offset) *socket-buffer-length*) + (setf (cl::uref stream cl::stream-input-buffer-pos-offset) 0) + (setf (cl::uref stream cl::stream-input-buffer-num-offset) 0) + stream)) + +(defun stream-socket-handle (stream) + "If the STREAM is a SOCKET-STREAM, return the socket handle + that the stream works on." + (cl::stream-handle stream)) + +(defmacro with-socket-stream ((stream socket) &body body) + "Creates a socket stream for the given SOCKET and closes it + when the scope of the macro ends." + `(let ((,stream (make-socket-stream ,socket))) + (unwind-protect + (progn + ,@body) + (close ,stream)))) + +;; Corman Lisp 1.41 exits if the following defvars are top-level +;; and evaluated twice by using LOAD twice on this file. +;; Fix is to wrap in UNLESS blocks testing for bound. +(unless (boundp 'old-read-line) + (defvar old-read-line #'cl::read-line)) + +(unless (boundp 'old-write-line) + (defvar old-write-line #'cl::write-line)) + +(unless (boundp 'old-close) + (defvar old-close #'cl::close)) + +(defun new-read-line (&optional + (s *standard-input*) + (eof-error-p t) + (eof-value nil) + (recursive-p nil)) + "Replacement for Corman Lisp READ-LINE to work with socket streams correctly." + (if (eq (cl::stream-subclass s) 'socket-stream) + (let ((result (funcall old-read-line s eof-error-p eof-value recursive-p))) + (if (and (stringp result) + (> (length result) 0) + (char= #\Return (char result (- (length result) 1)))) + (subseq result 0 (- (length result) 1)) + result)) + (funcall old-read-line s eof-error-p eof-value recursive-p))) + +(defun new-write-line (string &optional output-stream &key (start 0) end) + "Replacement for Corman Lisp WRITE-LINE to work with socket streams correctly." + (let ((string (if (and output-stream (eq (cl::stream-subclass output-stream) 'socket-stream)) + (concatenate 'string string (list #\Return)) + string))) + (funcall old-write-line string output-stream :start start :end end))) + +(defun new-close (stream &key abort) + "Replacement for Corman Lisp CLOSE to work with socket streams correctly." + (cond + ((typep stream 'base-socket) + (ignore-errors + (close-socket stream))) + ((and stream (eq (cl::stream-subclass stream) 'socket-stream)) + (ignore-errors + (force-output stream) + (close-socket (cl::stream-handle stream)))) + (t + (if abort + (funcall old-close stream :abort abort) + (funcall old-close stream))))) + +(setf (symbol-function 'common-lisp::read-line) #'new-read-line) +(setf (symbol-function 'common-lisp::write-line) #'new-write-line) +(setf (symbol-function 'common-lisp::close) #'new-close) + +(unless *sockets-started* + (start-sockets)) + +(provide 'SOCKETS) + +#| +;;Example of reading from an HTTP server. +(start-sockets) +(let ((s (make-client-socket :host "www.double.co.nz" :port 80))) + (write-socket-line s "GET / HTTP/1.0") + (write-socket-line s "") + (loop as line = (read-socket-line s nil :eof) + until (eq line :eof) + do (format t "~A~%" line)) + (close-socket s)) + +;; Same example using stream support +(let ((s (make-client-socket :host "www.double.co.nz" :port 80))) + (with-socket-stream (stream s) + (write-line "GET / HTTP/1.0" stream) + (write-line "" stream) + (force-output stream) + (loop as line = (read-line stream nil :eof) + until (eq line :eof) + do (format t "~A~%" line)))) + +;; Same example using a proxy +(let* ((*default-proxy-server* + (make-instance 'generic-proxy-server :host "proxy.myserver.com" :port 8080)) + (s (make-client-socket :host "www.double.co.nz" :port 80))) + (with-socket-stream (stream s) + (write-line "GET / HTTP/1.0" stream) + (write-line "" stream) + (force-output stream) + (loop as line = (read-line stream nil :eof) + until (eq line :eof) + do (format t "~A~%" line)))) + +;; Reading from an HTTP server, using Content-Length and SOCKET-READ. +;; Loops through the headers looking for Content-Length. When all the +;; headers are read, read the content data using the length previously +;; provided. +(with-client-socket (s :host "www.double.co.nz" :port 80) + (write-socket-line s "GET / HTTP/1.0") + (write-socket-line s "") + (let ((content-length 0)) + (loop as line = (read-socket-line s) + while (and line (> (length line) 0)) + do + (when (equal + (string-upcase (subseq line 0 (search ":" line))) + "CONTENT-LENGTH") + (setq content-length + (parse-integer line :start (+ (search ":" line) 1))))) + ;; Read contents + (read-socket s content-length))) + +;; Same example using stream support +(with-client-socket (s :host "www.double.co.nz" :port 80) + (with-socket-stream (stream s) + (write-line "GET / HTTP/1.0" stream) + (write-line "" stream) + (force-output stream) + (let ((content-length 0)) + (loop as line = (read-line stream nil :eof) + while (and (not (eq line :eof)) (> (length line) 0)) + do + (when (equal (string-upcase (subseq line 0 (search ":" line))) "CONTENT-LENGTH") + (setq content-length + (parse-integer line :start (+ (search ":" line) 1))))) + (format t "Total: ~A~%" content-length) + ;; Read contents + (let ((contents (make-string content-length))) + (read-sequence contents stream) + contents)))) + +;; Same example using a proxy +(let ((*default-proxy-server* + (make-instance 'generic-proxy-server :host "proxy.myserver.com" :port 8080))) + (with-client-socket (s :host "www.double.co.nz" :port 80) + (with-socket-stream (stream s) + (write-line "GET / HTTP/1.0" stream) + (write-line "" stream) + (force-output stream) + (let ((content-length 0)) + (loop as line = (read-line stream nil :eof) + while (and (not (eq line :eof)) (> (length line) 0)) + do + (when (equal (string-upcase (subseq line 0 (search ":" line))) "CONTENT-LENGTH") + (setq content-length + (parse-integer line :start (+ (search ":" line) 1))))) + (format t "Total: ~A~%" content-length) + ;; Read contents + (let ((contents (make-string content-length))) + (read-sequence contents stream) + contents))))) + +;; NNTP - retrieves help text from nntp server and uses with-client-socket +(with-client-socket (ns :host "news.xtra.co.nz" :port 119) + (format t "~A~%" (read-socket-line ns)) + (write-socket-line ns "help") + (loop as line = (read-socket-line ns) + while (and line (not (eql (elt line 0) #\.))) + do (format t "~A~%" line))) + +;; Same example using streams +(with-client-socket (s :host "news.xtra.co.nz" :port 119) + (with-socket-stream (stream s) + (format t "~A~%" (read-line stream)) + (write-line "help" stream) + (force-output stream) + (loop as line = (read-line stream nil :eof) + while (and (not (eq line :eof)) (not (eql (elt line 0) #\.))) + do (format t "~A~%" line)))) + +;; Server test - echoes lines back to client until 'quit' is received, then closes down. +(defun start-server-test (&optional (port 8001)) + (with-server-socket (s :host "0.0.0.0" :port port) + (with-server-accept (remote-socket s) + (format t "Connection made ~A ~A~%" + (socket-descriptor remote-socket) (socket-descriptor s)) + (loop + (let ((value (read-socket-line remote-socket nil :eof))) + (when (eq value :eof) + (return)) + (format t "~A~%" value) + (force-output *standard-output*) + (write-socket-line remote-socket value) + (when (equal value "quit") + (return))))))) +(start-server-test) + +;; Start the above server in a seperate thread, and connect to it on the current thread. +(th:create-thread #'start-server-test) +(with-client-socket (s :host "localhost" :port 8001) + (write-socket-line s "Hello Socket World!") + (format t "Got: ~A~%" (read-socket-line s)) + (write-socket-line s "quit")) + +;; with streams... +(th:create-thread #'start-server-test) +(with-client-socket (s :host "localhost" :port 8001) + (with-socket-stream (stream s) + (write-line "Hello Socket World!" stream) + (force-output stream) + (format t "Got: ~A~%" (read-line stream)) + (write-line "quit" stream))) + +;; Another server test - uses start-socket-server and streams +(defun start-server-test2 (&optional (port 8000)) + (with-server-socket (s :host "0.0.0.0" :port port) + (start-socket-server (s rs) + (let ((stream (make-socket-stream rs))) + (when (equal (read-line stream) "quit") + (return-from start-server-test2)) + (write-line + (coerce (make-list 80 :initial-element #\Z) 'string) + stream) + (write-line + (coerce (make-list 80 :initial-element #\A) 'string) + stream) + (force-output stream))))) +(th:create-thread #'start-server-test2) + +;; Use the server +(with-client-socket (s :host "localhost" :port 8000) + (write-socket-line s "GO") + (format t "~A~%" (read-socket-line s)) + (format t "~A~%" (read-socket-line s))) + +;; Use the server with streams +(with-client-socket (s :host "localhost" :port 8000) + (with-socket-stream (stream s) + (write-line "GO" stream) + (force-output stream) + (format t "~A~%" (read-line stream)) + (format t "~A~%" (read-line stream)))) + +;; Close the server +(with-client-socket (s :host "localhost" :port 8000) + (write-socket-line s "quit")) + +|# diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\split-seq.lisp corman\Modules\split-seq.lisp --- corman3\Modules\split-seq.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\split-seq.lisp Sat Feb 11 09:10:23 2006 @@ -0,0 +1,245 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; ; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication here, which is kept +;;; to illustrate the relationship between the SPLIT-SEQUENCE +;;; functions and the CL:POSITION functions. + +;;; Examples: +;;; +;;; * (split-sequence #\; "a;;b;c") +;;; -> ("a" "" "b" "c"), 6 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t) +;;; -> ("a" "" "b" "c"), 0 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) +;;; -> ("c"), 4 +;;; +;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) +;;; -> ("a" "b" "c"), 6 +;;; +;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 +;;; +;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("ab" "a" "a" "ab" "a"), 11 +;;; +;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) +;;; -> ("oo" "bar" "b"), 9 + +(defpackage "SPLIT-SEQ" + (:use "CL") + (:nicknames "PARTITION") + (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" + "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) + +(in-package "SPLIT-SEQ") + +(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by delimiter. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +(CL:COMPLEMENT predicate). + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if-not predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if-not predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +;;; clean deprecation + +(defun partition (&rest args) + (apply #'split-sequence args)) + +(defun partition-if (&rest args) + (apply #'split-sequence-if args)) + +(defun partition-if-not (&rest args) + (apply #'split-sequence-if-not args)) + +(define-compiler-macro partition (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") + form) + +(define-compiler-macro partition-if (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") + form) + +(define-compiler-macro partition-if-not (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") + form) + +(pushnew :split-sequence *features*) + +(provide 'split-sequence) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\unit-test.lisp corman\Modules\unit-test.lisp --- corman3\Modules\unit-test.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\unit-test.lisp Tue Feb 14 10:36:41 2006 @@ -0,0 +1,39 @@ +(require 'macro-utilities) +(use-package :com.gigamonkeys.macro-utilities) + +(in-package :cl-user) + +(defpackage "COM.GIGAMONKEYS.UNIT-TEST" + (:nicknames "UNIT-TEST") + (:use :common-lisp :macro-utilities) + (:export + "DEFTEST" + "CHECK")) + +(in-package :com.gigamonkeys.unit-test) + +(defvar *test-name* nil) + +(defmacro deftest (name parameters &body body) + "Define a test function. Within a test function we can call other +test functions or use `check' to run individual test cases." + `(defun ,name ,parameters + (let ((*test-name* (append *test-name* (list ',name)))) + ,@body))) + +(defmacro check (&body forms) + "Run each expression in `forms' as a test case." + `(combine-results + ,@(loop for f in forms collect `(report-result ,f ',f)))) + +(defmacro combine-results (&body forms) + "Combine the results (as booleans) of evaluating `forms' in order." + (with-gensyms (result) + `(let ((,result t)) + ,@(loop for f in forms collect `(unless ,f (setf ,result nil))) + ,result))) + +(defun report-result (result form) + "Report the results of a single test case. Called by `check'." + (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form) + result) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Modules\winsock.lisp corman\Modules\winsock.lisp --- corman3\Modules\winsock.lisp Wed Dec 31 16:00:00 1969 +++ corman\Modules\winsock.lisp Mon Jul 31 07:33:12 2006 @@ -0,0 +1,919 @@ +;;;; winsock.lisp -- Winsock definitions for Corman Lisp + +;;;; Author: Roger Corman +;;;; Created: 8/10/99 +;;;; Last modified: 8/10/99 + +;;;; This is (for now) just a no-frills equivalent of the following +;;;; file: +;;;; +;;;; WINSOCK.H + +(make-package "WINSOCK" :use '("COMMON-LISP" "C-TYPES")) +(in-package :winsock) + +#! (:export t :library "WS2_32") +/* + * Basic system type definitions, taken from the BSD file sys/types.h. + */ +typedef unsigned char u_char; +typedef unsigned short u_short; +typedef unsigned int u_int; +typedef unsigned long u_long; +typedef unsigned short WORD; // XXX RGC addition. + +/* + * The new type to be used in all + * instances which refer to sockets. + */ +typedef u_int SOCKET; + +/* + * Select uses arrays of SOCKETs. These macros manipulate such + * arrays. FD_SETSIZE may be defined by the user before including + * this file, but the default here should be >= 64. + * + * CAVEAT IMPLEMENTOR and USER: THESE MACROS AND TYPES MUST BE + * INCLUDED IN WINSOCK.H EXACTLY AS SHOWN HERE. + */ +//#ifndef FD_SETSIZE +#define FD_SETSIZE 64 +//#endif /* FD_SETSIZE */ + +typedef struct fd_set { + u_int fd_count; /* how many are SET? */ + SOCKET fd_array[FD_SETSIZE]; /* an array of SOCKETs */ +} fd_set; + +//#ifdef __cplusplus +//extern "C" { +//#endif + +/*extern*/ int PASCAL /*FAR*/ __WSAFDIsSet(SOCKET, fd_set FAR *); + +//#ifdef __cplusplus +//} +//#endif + +/* +#define FD_CLR(fd, set) do { \ + u_int __i; \ + for (__i = 0; __i < ((fd_set FAR *)(set))->fd_count ; __i++) { \ + if (((fd_set FAR *)(set))->fd_array[__i] == fd) { \ + while (__i < ((fd_set FAR *)(set))->fd_count-1) { \ + ((fd_set FAR *)(set))->fd_array[__i] = \ + ((fd_set FAR *)(set))->fd_array[__i+1]; \ + __i++; \ + } \ + ((fd_set FAR *)(set))->fd_count--; \ + break; \ + } \ + } \ +} while(0) + +#define FD_SET(fd, set) do { \ + if (((fd_set FAR *)(set))->fd_count < FD_SETSIZE) \ + ((fd_set FAR *)(set))->fd_array[((fd_set FAR *)(set))->fd_count++]=(fd);\ +} while(0) + +#define FD_ZERO(set) (((fd_set FAR *)(set))->fd_count=0) + +#define FD_ISSET(fd, set) __WSAFDIsSet((SOCKET)(fd), (fd_set FAR *)(set)) +*/ + +/* + * Structure used in select() call, taken from the BSD file sys/time.h. + */ +struct timeval { + long tv_sec; /* seconds */ + long tv_usec; /* and microseconds */ +}; + +/* + * Operations on timevals. + * + * NB: timercmp does not work for >= or <=. + */ +/* +#define timerisset(tvp) ((tvp)->tv_sec || (tvp)->tv_usec) +#define timercmp(tvp, uvp, cmp) \ + ((tvp)->tv_sec cmp (uvp)->tv_sec || \ + (tvp)->tv_sec == (uvp)->tv_sec && (tvp)->tv_usec cmp (uvp)->tv_usec) +#define timerclear(tvp) (tvp)->tv_sec = (tvp)->tv_usec = 0 +*/ +/* + * Commands for ioctlsocket(), taken from the BSD file fcntl.h. + * + * + * Ioctl's have the command encoded in the lower word, + * and the size of any in or out parameters in the upper + * word. The high 2 bits of the upper word are used + * to encode the in/out status of the parameter; for now + * we restrict parameters to at most 128 bytes. + */ +#define IOCPARM_MASK 0x7f /* parameters must be < 128 bytes */ +#define IOC_VOID 0x20000000 /* no parameters */ +#define IOC_OUT 0x40000000 /* copy out parameters */ +#define IOC_IN 0x80000000 /* copy in parameters */ +#define IOC_INOUT (IOC_IN|IOC_OUT) + /* 0x20000000 distinguishes new & + old ioctl's */ +//#define _IO(x,y) (IOC_VOID|((x)<<8)|(y)) + +//#define _IOR(x,y,t) (IOC_OUT|(((long)sizeof(t)&IOCPARM_MASK)<<16)|((x)<<8)|(y)) + +//#define _IOW(x,y,t) (IOC_IN|(((long)sizeof(t)&IOCPARM_MASK)<<16)|((x)<<8)|(y)) + +//#define FIONREAD _IOR('f', 127, u_long) /* get # bytes to read */ +//#define FIONBIO _IOW('f', 126, u_long) /* set/clear non-blocking i/o */ +//#define FIOASYNC _IOW('f', 125, u_long) /* set/clear async i/o */ + +/* Socket I/O Controls */ +//#define SIOCSHIWAT _IOW('s', 0, u_long) /* set high watermark */ +//#define SIOCGHIWAT _IOR('s', 1, u_long) /* get high watermark */ +//#define SIOCSLOWAT _IOW('s', 2, u_long) /* set low watermark */ +//#define SIOCGLOWAT _IOR('s', 3, u_long) /* get low watermark */ +//#define SIOCATMARK _IOR('s', 7, u_long) /* at oob mark? */ + +/* + * Structures returned by network data base library, taken from the + * BSD file netdb.h. All addresses are supplied in host order, and + * returned in network order (suitable for use in system calls). + */ + +struct hostent { + char FAR * h_name; /* official name of host */ + char FAR * FAR * h_aliases; /* alias list */ + short h_addrtype; /* host address type */ + short h_length; /* length of address */ + char FAR * FAR * h_addr_list; /* list of addresses */ +//#define h_addr h_addr_list[0] /* address, for backward compat */ +}; + +/* + * It is assumed here that a network number + * fits in 32 bits. + */ +struct netent { + char FAR * n_name; /* official name of net */ + char FAR * FAR * n_aliases; /* alias list */ + short n_addrtype; /* net address type */ + u_long n_net; /* network # */ +}; + +struct servent { + char FAR * s_name; /* official service name */ + char FAR * FAR * s_aliases; /* alias list */ + short s_port; /* port # */ + char FAR * s_proto; /* protocol to use */ +}; + +struct protoent { + char FAR * p_name; /* official protocol name */ + char FAR * FAR * p_aliases; /* alias list */ + short p_proto; /* protocol # */ +}; + +/* + * Constants and structures defined by the internet system, + * Per RFC 790, September 1981, taken from the BSD file netinet/in.h. + */ + +/* + * Protocols + */ +#define IPPROTO_IP 0 /* dummy for IP */ +#define IPPROTO_ICMP 1 /* control message protocol */ +#define IPPROTO_IGMP 2 /* group management protocol */ +#define IPPROTO_GGP 3 /* gateway^2 (deprecated) */ +#define IPPROTO_TCP 6 /* tcp */ +#define IPPROTO_PUP 12 /* pup */ +#define IPPROTO_UDP 17 /* user datagram protocol */ +#define IPPROTO_IDP 22 /* xns idp */ +#define IPPROTO_ND 77 /* UNOFFICIAL net disk proto */ + +#define IPPROTO_RAW 255 /* raw IP packet */ +#define IPPROTO_MAX 256 + +/* + * Port/socket numbers: network standard functions + */ +#define IPPORT_ECHO 7 +#define IPPORT_DISCARD 9 +#define IPPORT_SYSTAT 11 +#define IPPORT_DAYTIME 13 +#define IPPORT_NETSTAT 15 +#define IPPORT_FTP 21 +#define IPPORT_TELNET 23 +#define IPPORT_SMTP 25 +#define IPPORT_TIMESERVER 37 +#define IPPORT_NAMESERVER 42 +#define IPPORT_WHOIS 43 +#define IPPORT_MTP 57 + +/* + * Port/socket numbers: host specific functions + */ +#define IPPORT_TFTP 69 +#define IPPORT_RJE 77 +#define IPPORT_FINGER 79 +#define IPPORT_TTYLINK 87 +#define IPPORT_SUPDUP 95 + +/* + * UNIX TCP sockets + */ +#define IPPORT_EXECSERVER 512 +#define IPPORT_LOGINSERVER 513 +#define IPPORT_CMDSERVER 514 +#define IPPORT_EFSSERVER 520 + +/* + * UNIX UDP sockets + */ +#define IPPORT_BIFFUDP 512 +#define IPPORT_WHOSERVER 513 +#define IPPORT_ROUTESERVER 520 + /* 520+1 also used */ + +/* + * Ports < IPPORT_RESERVED are reserved for + * privileged processes (e.g. root). + */ +#define IPPORT_RESERVED 1024 + +/* + * Link numbers + */ +#define IMPLINK_IP 155 +#define IMPLINK_LOWEXPER 156 +#define IMPLINK_HIGHEXPER 158 + +/* + * Internet address (old style... should be updated) + */ + +//struct in_addr { + // union { + // struct { u_char s_b1,s_b2,s_b3,s_b4; } S_un_b; + // struct { u_short s_w1,s_w2; } S_un_w; + // u_long S_addr; + // } S_un; +//#define s_addr S_un.S_addr + /* can be used for most tcp & ip code */ +//#define s_host S_un.S_un_b.s_b2 + /* host on imp */ +//#define s_net S_un.S_un_b.s_b1 + /* network */ +//#define s_imp S_un.S_un_w.s_w2 + /* imp */ +//#define s_impno S_un.S_un_b.s_b4 + /* imp # */ +//#define s_lh S_un.S_un_b.s_b3 + /* logical host */ +//}; +struct in_addr { + u_long S_addr; + }; + +/* + * Definitions of bits in internet address integers. + * On subnets, the decomposition of addresses to host and net parts + * is done according to subnet mask, not the masks here. + */ +//#define IN_CLASSA(i) (((long)(i) & 0x80000000) == 0) +#define IN_CLASSA_NET 0xff000000 +#define IN_CLASSA_NSHIFT 24 +#define IN_CLASSA_HOST 0x00ffffff +#define IN_CLASSA_MAX 128 + +//#define IN_CLASSB(i) (((long)(i) & 0xc0000000) == 0x80000000) +#define IN_CLASSB_NET 0xffff0000 +#define IN_CLASSB_NSHIFT 16 +#define IN_CLASSB_HOST 0x0000ffff +#define IN_CLASSB_MAX 65536 + +//#define IN_CLASSC(i) (((long)(i) & 0xe0000000) == 0xc0000000) +#define IN_CLASSC_NET 0xffffff00 +#define IN_CLASSC_NSHIFT 8 +#define IN_CLASSC_HOST 0x000000ff + +#define INADDR_ANY /*(u_long)*/0x00000000 +#define INADDR_LOOPBACK 0x7f000001 +#define INADDR_BROADCAST /*(u_long)*/0xffffffff +#define INADDR_NONE 0xffffffff + +/* + * Socket address, internet style. + */ +struct sockaddr_in { + short sin_family; + u_short sin_port; + /*struct*/ in_addr sin_addr; + char sin_zero[8]; +}; + +#define WSADESCRIPTION_LEN 256 +#define WSASYS_STATUS_LEN 128 + +typedef struct WSAData { + unsigned short wVersion; + unsigned short wHighVersion; + char szDescription[/*WSADESCRIPTION_LEN+1*/257]; + char szSystemStatus[/*WSASYS_STATUS_LEN+1*/129]; + unsigned short iMaxSockets; + unsigned short iMaxUdpDg; + char FAR * lpVendorInfo; +} WSADATA; + +typedef WSADATA FAR *LPWSADATA; + +/* + * Options for use with [gs]etsockopt at the IP level. + */ +#define IP_OPTIONS 1 /* set/get IP per-packet options */ +#define IP_MULTICAST_IF 2 /* set/get IP multicast interface */ +#define IP_MULTICAST_TTL 3 /* set/get IP multicast timetolive */ +#define IP_MULTICAST_LOOP 4 /* set/get IP multicast loopback */ +#define IP_ADD_MEMBERSHIP 5 /* add an IP group membership */ +#define IP_DROP_MEMBERSHIP 6 /* drop an IP group membership */ +#define IP_TTL 7 /* set/get IP Time To Live */ +#define IP_TOS 8 /* set/get IP Type Of Service */ +#define IP_DONTFRAGMENT 9 /* set/get IP Don't Fragment flag */ + + +#define IP_DEFAULT_MULTICAST_TTL 1 /* normally limit m'casts to 1 hop */ +#define IP_DEFAULT_MULTICAST_LOOP 1 /* normally hear sends if a member */ +#define IP_MAX_MEMBERSHIPS 20 /* per socket; must fit in one mbuf */ + +/* + * Argument structure for IP_ADD_MEMBERSHIP and IP_DROP_MEMBERSHIP. + */ +struct ip_mreq { + /*struct*/ in_addr imr_multiaddr; /* IP multicast address of group */ + /*struct*/ in_addr imr_interface; /* local IP address of interface */ +}; + +/* + * Definitions related to sockets: types, address families, options, + * taken from the BSD file sys/socket.h. + */ + +/* + * This is used instead of -1, since the + * SOCKET type is unsigned. + */ +#define INVALID_SOCKET 0xffffffff +#define SOCKET_ERROR (-1) + +/* + * Types + */ +#define SOCK_STREAM 1 /* stream socket */ +#define SOCK_DGRAM 2 /* datagram socket */ +#define SOCK_RAW 3 /* raw-protocol interface */ +#define SOCK_RDM 4 /* reliably-delivered message */ +#define SOCK_SEQPACKET 5 /* sequenced packet stream */ + +/* + * Option flags per-socket. + */ +#define SO_DEBUG 0x0001 /* turn on debugging info recording */ +#define SO_ACCEPTCONN 0x0002 /* socket has had listen() */ +#define SO_REUSEADDR 0x0004 /* allow local address reuse */ +#define SO_KEEPALIVE 0x0008 /* keep connections alive */ +#define SO_DONTROUTE 0x0010 /* just use interface addresses */ +#define SO_BROADCAST 0x0020 /* permit sending of broadcast msgs */ +#define SO_USELOOPBACK 0x0040 /* bypass hardware when possible */ +#define SO_LINGER 0x0080 /* linger on close if data present */ +#define SO_OOBINLINE 0x0100 /* leave received OOB data in line */ + +//#define SO_DONTLINGER (u_int)(~SO_LINGER) + +/* + * Additional options. + */ +#define SO_SNDBUF 0x1001 /* send buffer size */ +#define SO_RCVBUF 0x1002 /* receive buffer size */ +#define SO_SNDLOWAT 0x1003 /* send low-water mark */ +#define SO_RCVLOWAT 0x1004 /* receive low-water mark */ +#define SO_SNDTIMEO 0x1005 /* send timeout */ +#define SO_RCVTIMEO 0x1006 /* receive timeout */ +#define SO_ERROR 0x1007 /* get error status and clear */ +#define SO_TYPE 0x1008 /* get socket type */ + +/* + * Options for connect and disconnect data and options. Used only by + * non-TCP/IP transports such as DECNet, OSI TP4, etc. + */ +#define SO_CONNDATA 0x7000 +#define SO_CONNOPT 0x7001 +#define SO_DISCDATA 0x7002 +#define SO_DISCOPT 0x7003 +#define SO_CONNDATALEN 0x7004 +#define SO_CONNOPTLEN 0x7005 +#define SO_DISCDATALEN 0x7006 +#define SO_DISCOPTLEN 0x7007 + +/* + * Option for opening sockets for synchronous access. + */ +#define SO_OPENTYPE 0x7008 + +#define SO_SYNCHRONOUS_ALERT 0x10 +#define SO_SYNCHRONOUS_NONALERT 0x20 + +/* + * Other NT-specific options. + */ +#define SO_MAXDG 0x7009 +#define SO_MAXPATHDG 0x700A +#define SO_UPDATE_ACCEPT_CONTEXT 0x700B +#define SO_CONNECT_TIME 0x700C + +/* + * TCP options. + */ +#define TCP_NODELAY 0x0001 +#define TCP_BSDURGENT 0x7000 + +/* + * Address families. + */ +#define AF_UNSPEC 0 /* unspecified */ +#define AF_UNIX 1 /* local to host (pipes, portals) */ +#define AF_INET 2 /* internetwork: UDP, TCP, etc. */ +#define AF_IMPLINK 3 /* arpanet imp addresses */ +#define AF_PUP 4 /* pup protocols: e.g. BSP */ +#define AF_CHAOS 5 /* mit CHAOS protocols */ +#define AF_IPX 6 /* IPX and SPX */ +#define AF_NS 6 /* XEROX NS protocols */ +#define AF_ISO 7 /* ISO protocols */ +#define AF_OSI AF_ISO /* OSI is ISO */ +#define AF_ECMA 8 /* european computer manufacturers */ +#define AF_DATAKIT 9 /* datakit protocols */ +#define AF_CCITT 10 /* CCITT protocols, X.25 etc */ +#define AF_SNA 11 /* IBM SNA */ +#define AF_DECnet 12 /* DECnet */ +#define AF_DLI 13 /* Direct data link interface */ +#define AF_LAT 14 /* LAT */ +#define AF_HYLINK 15 /* NSC Hyperchannel */ +#define AF_APPLETALK 16 /* AppleTalk */ +#define AF_NETBIOS 17 /* NetBios-style addresses */ +#define AF_VOICEVIEW 18 /* VoiceView */ +#define AF_FIREFOX 19 /* FireFox */ +#define AF_UNKNOWN1 20 /* Somebody is using this! */ +#define AF_BAN 21 /* Banyan */ + +#define AF_MAX 22 + +/* + * Structure used by kernel to store most + * addresses. + */ +struct sockaddr { + u_short sa_family; /* address family */ + char sa_data[14]; /* up to 14 bytes of direct address */ +}; + +/* + * Structure used by kernel to pass protocol + * information in raw sockets. + */ +struct sockproto { + u_short sp_family; /* address family */ + u_short sp_protocol; /* protocol */ +}; + +/* + * Protocol families, same as address families for now. + */ +#define PF_UNSPEC AF_UNSPEC +#define PF_UNIX AF_UNIX +#define PF_INET AF_INET +#define PF_IMPLINK AF_IMPLINK +#define PF_PUP AF_PUP +#define PF_CHAOS AF_CHAOS +#define PF_NS AF_NS +#define PF_IPX AF_IPX +#define PF_ISO AF_ISO +#define PF_OSI AF_OSI +#define PF_ECMA AF_ECMA +#define PF_DATAKIT AF_DATAKIT +#define PF_CCITT AF_CCITT +#define PF_SNA AF_SNA +#define PF_DECnet AF_DECnet +#define PF_DLI AF_DLI +#define PF_LAT AF_LAT +#define PF_HYLINK AF_HYLINK +#define PF_APPLETALK AF_APPLETALK +#define PF_VOICEVIEW AF_VOICEVIEW +#define PF_FIREFOX AF_FIREFOX +#define PF_UNKNOWN1 AF_UNKNOWN1 +#define PF_BAN AF_BAN + +#define PF_MAX AF_MAX + +/* + * Structure used for manipulating linger option. + */ +struct linger { + u_short l_onoff; /* option on/off */ + u_short l_linger; /* linger time */ +}; + +/* + * Level number for (get/set)sockopt() to apply to socket itself. + */ +#define SOL_SOCKET 0xffff /* options for socket level */ + +/* + * Maximum queue length specifiable by listen. + */ +#define SOMAXCONN 5 + +#define MSG_OOB 0x1 /* process out-of-band data */ +#define MSG_PEEK 0x2 /* peek at incoming message */ +#define MSG_DONTROUTE 0x4 /* send without using routing tables */ + +#define MSG_MAXIOVLEN 16 + +#define MSG_PARTIAL 0x8000 /* partial send or recv for message xport */ + +/* + * Define constant based on rfc883, used by gethostbyxxxx() calls. + */ +#define MAXGETHOSTSTRUCT 1024 + +/* + * Define flags to be used with the WSAAsyncSelect() call. + */ +#define FD_READ 0x01 +#define FD_WRITE 0x02 +#define FD_OOB 0x04 +#define FD_ACCEPT 0x08 +#define FD_CONNECT 0x10 +#define FD_CLOSE 0x20 + +/* + * All Windows Sockets error constants are biased by WSABASEERR from + * the "normal" + */ +#define WSABASEERR 10000 +/* + * Windows Sockets definitions of regular Microsoft C error constants + */ +#define WSAEINTR (WSABASEERR+4) +#define WSAEBADF (WSABASEERR+9) +#define WSAEACCES (WSABASEERR+13) +#define WSAEFAULT (WSABASEERR+14) +#define WSAEINVAL (WSABASEERR+22) +#define WSAEMFILE (WSABASEERR+24) + +/* + * Windows Sockets definitions of regular Berkeley error constants + */ +#define WSAEWOULDBLOCK (WSABASEERR+35) +#define WSAEINPROGRESS (WSABASEERR+36) +#define WSAEALREADY (WSABASEERR+37) +#define WSAENOTSOCK (WSABASEERR+38) +#define WSAEDESTADDRREQ (WSABASEERR+39) +#define WSAEMSGSIZE (WSABASEERR+40) +#define WSAEPROTOTYPE (WSABASEERR+41) +#define WSAENOPROTOOPT (WSABASEERR+42) +#define WSAEPROTONOSUPPORT (WSABASEERR+43) +#define WSAESOCKTNOSUPPORT (WSABASEERR+44) +#define WSAEOPNOTSUPP (WSABASEERR+45) +#define WSAEPFNOSUPPORT (WSABASEERR+46) +#define WSAEAFNOSUPPORT (WSABASEERR+47) +#define WSAEADDRINUSE (WSABASEERR+48) +#define WSAEADDRNOTAVAIL (WSABASEERR+49) +#define WSAENETDOWN (WSABASEERR+50) +#define WSAENETUNREACH (WSABASEERR+51) +#define WSAENETRESET (WSABASEERR+52) +#define WSAECONNABORTED (WSABASEERR+53) +#define WSAECONNRESET (WSABASEERR+54) +#define WSAENOBUFS (WSABASEERR+55) +#define WSAEISCONN (WSABASEERR+56) +#define WSAENOTCONN (WSABASEERR+57) +#define WSAESHUTDOWN (WSABASEERR+58) +#define WSAETOOMANYREFS (WSABASEERR+59) +#define WSAETIMEDOUT (WSABASEERR+60) +#define WSAECONNREFUSED (WSABASEERR+61) +#define WSAELOOP (WSABASEERR+62) +#define WSAENAMETOOLONG (WSABASEERR+63) +#define WSAEHOSTDOWN (WSABASEERR+64) +#define WSAEHOSTUNREACH (WSABASEERR+65) +#define WSAENOTEMPTY (WSABASEERR+66) +#define WSAEPROCLIM (WSABASEERR+67) +#define WSAEUSERS (WSABASEERR+68) +#define WSAEDQUOT (WSABASEERR+69) +#define WSAESTALE (WSABASEERR+70) +#define WSAEREMOTE (WSABASEERR+71) + +#define WSAEDISCON (WSABASEERR+101) + +/* + * Extended Windows Sockets error constant definitions + */ +#define WSASYSNOTREADY (WSABASEERR+91) +#define WSAVERNOTSUPPORTED (WSABASEERR+92) +#define WSANOTINITIALISED (WSABASEERR+93) + +/* + * Error return codes from gethostbyname() and gethostbyaddr() + * (when using the resolver). Note that these errors are + * retrieved via WSAGetLastError() and must therefore follow + * the rules for avoiding clashes with error numbers from + * specific implementations or language run-time systems. + * For this reason the codes are based at WSABASEERR+1001. + * Note also that [WSA]NO_ADDRESS is defined only for + * compatibility purposes. + */ + +//#define h_errno WSAGetLastError() + +/* Authoritative Answer: Host not found */ +#define WSAHOST_NOT_FOUND (WSABASEERR+1001) +#define HOST_NOT_FOUND WSAHOST_NOT_FOUND + +/* Non-Authoritative: Host not found, or SERVERFAIL */ +#define WSATRY_AGAIN (WSABASEERR+1002) +#define TRY_AGAIN WSATRY_AGAIN + +/* Non recoverable errors, FORMERR, REFUSED, NOTIMP */ +#define WSANO_RECOVERY (WSABASEERR+1003) +#define NO_RECOVERY WSANO_RECOVERY + +/* Valid name, no data record of requested type */ +#define WSANO_DATA (WSABASEERR+1004) +#define NO_DATA WSANO_DATA + +/* no address, look for MX record */ +#define WSANO_ADDRESS WSANO_DATA +#define NO_ADDRESS WSANO_ADDRESS + +!# + +#! (:export t :library "WS2_32") + +/* Socket function prototypes */ + +//#ifdef __cplusplus +//extern "C" { +//#endif + +SOCKET PASCAL FAR accept (SOCKET s, sockaddr FAR *addr, + int FAR *addrlen); + +int PASCAL FAR bind (SOCKET s, const sockaddr FAR *addr, int namelen); + +int PASCAL FAR closesocket (SOCKET s); + +int PASCAL FAR connect (SOCKET s, const sockaddr FAR *name, int namelen); + +int PASCAL FAR ioctlsocket (SOCKET s, long cmd, u_long FAR *argp); + +int PASCAL FAR getpeername (SOCKET s, sockaddr FAR *name, + int FAR * namelen); + +int PASCAL FAR getsockname (SOCKET s, sockaddr FAR *name, + int FAR * namelen); + +int PASCAL FAR getsockopt (SOCKET s, int level, int optname, + char FAR * optval, int FAR *optlen); + +u_long PASCAL FAR htonl (u_long hostlong); + +u_short PASCAL FAR htons (u_short hostshort); + +unsigned long PASCAL FAR inet_addr (const char FAR * cp); + +char FAR * PASCAL FAR inet_ntoa (in_addr in); + +int PASCAL FAR listen (SOCKET s, int backlog); + +u_long PASCAL FAR ntohl (u_long netlong); + +u_short PASCAL FAR ntohs (u_short netshort); + +int PASCAL FAR recv (SOCKET s, char FAR * buf, int len, int flags); + +int PASCAL FAR recvfrom (SOCKET s, char FAR * buf, int len, int flags, + sockaddr FAR *from, int FAR * fromlen); + +int PASCAL FAR select (int nfds, fd_set FAR *readfds, fd_set FAR *writefds, + fd_set FAR *exceptfds, const timeval FAR *timeout); + +int PASCAL FAR send (SOCKET s, const char FAR * buf, int len, int flags); + +int PASCAL FAR sendto (SOCKET s, const char FAR * buf, int len, int flags, + const sockaddr FAR *to, int tolen); + +int PASCAL FAR setsockopt (SOCKET s, int level, int optname, + const char FAR * optval, int optlen); + +int PASCAL FAR shutdown (SOCKET s, int how); + +SOCKET PASCAL FAR socket (int af, int type, int protocol); + +/* Database function prototypes */ + +hostent FAR * PASCAL FAR gethostbyaddr(const char FAR * addr, + int len, int type); + +hostent FAR * PASCAL FAR gethostbyname(const char FAR * name); + +int PASCAL FAR gethostname (char FAR * name, int namelen); + +servent FAR * PASCAL FAR getservbyport(int port, const char FAR * proto); + +servent FAR * PASCAL FAR getservbyname(const char FAR * name, + const char FAR * proto); + +protoent FAR * PASCAL FAR getprotobynumber(int proto); + +protoent FAR * PASCAL FAR getprotobyname(const char FAR * name); + +/* Microsoft Windows Extension function prototypes */ + +int PASCAL FAR WSAStartup(WORD wVersionRequired, LPWSADATA lpWSAData); + +int PASCAL FAR WSACleanup(); + +void PASCAL FAR WSASetLastError(int iError); + +int PASCAL FAR WSAGetLastError(); + +BOOL PASCAL FAR WSAIsBlocking(); + +int PASCAL FAR WSAUnhookBlockingHook(); + +FARPROC PASCAL FAR WSASetBlockingHook(FARPROC lpBlockFunc); + +int PASCAL FAR WSACancelBlockingCall(); + +HANDLE PASCAL FAR WSAAsyncGetServByName(HWND hWnd, u_int wMsg, + const char FAR * name, + const char FAR * proto, + char FAR * buf, int buflen); + +HANDLE PASCAL FAR WSAAsyncGetServByPort(HWND hWnd, u_int wMsg, int port, + const char FAR * proto, char FAR * buf, + int buflen); + +HANDLE PASCAL FAR WSAAsyncGetProtoByName(HWND hWnd, u_int wMsg, + const char FAR * name, char FAR * buf, + int buflen); + +HANDLE PASCAL FAR WSAAsyncGetProtoByNumber(HWND hWnd, u_int wMsg, + int number, char FAR * buf, + int buflen); + +HANDLE PASCAL FAR WSAAsyncGetHostByName(HWND hWnd, u_int wMsg, + const char FAR * name, char FAR * buf, + int buflen); + +HANDLE PASCAL FAR WSAAsyncGetHostByAddr(HWND hWnd, u_int wMsg, + const char FAR * addr, int len, int type, + char FAR * buf, int buflen); + +int PASCAL FAR WSACancelAsyncRequest(HANDLE hAsyncTaskHandle); + +int PASCAL FAR WSAAsyncSelect(SOCKET s, HWND hWnd, u_int wMsg, + long lEvent); + +int PASCAL FAR WSARecvEx (SOCKET s, char FAR * buf, int len, int FAR *flags); + +typedef struct _TRANSMIT_FILE_BUFFERS { + void* Head; + unsigned long HeadLength; + void* Tail; + unsigned long TailLength; +} TRANSMIT_FILE_BUFFERS, *PTRANSMIT_FILE_BUFFERS, *LPTRANSMIT_FILE_BUFFERS; + +#define TF_DISCONNECT 0x01 +#define TF_REUSE_SOCKET 0x02 +#define TF_WRITE_BEHIND 0x04 + +BOOL +PASCAL FAR +TransmitFile ( + /*IN*/ SOCKET hSocket, + /*IN*/ HANDLE hFile, + /*IN*/ DWORD nNumberOfBytesToWrite, + /*IN*/ DWORD nNumberOfBytesPerSend, + /*IN*/ LPOVERLAPPED lpOverlapped, + /*IN*/ LPTRANSMIT_FILE_BUFFERS lpTransmitBuffers, + /*IN*/ DWORD dwReserved + ); + +BOOL +PASCAL FAR +AcceptEx ( + /*IN*/ SOCKET sListenSocket, + /*IN*/ SOCKET sAcceptSocket, + /*IN*/ PVOID lpOutputBuffer, + /*IN*/ DWORD dwReceiveDataLength, + /*IN*/ DWORD dwLocalAddressLength, + /*IN*/ DWORD dwRemoteAddressLength, + /*OUT*/ LPDWORD lpdwBytesReceived, + /*IN*/ LPOVERLAPPED lpOverlapped + ); + +VOID +PASCAL FAR +GetAcceptExSockaddrs ( + /*IN*/ PVOID lpOutputBuffer, + /*IN*/ DWORD dwReceiveDataLength, + /*IN*/ DWORD dwLocalAddressLength, + /*IN*/ DWORD dwRemoteAddressLength, + /*OUT*/ sockaddr **LocalSockaddr, + /*OUT*/ LPINT LocalSockaddrLength, + /*OUT*/ sockaddr **RemoteSockaddr, + /*OUT*/ LPINT RemoteSockaddrLength + ); + +//#ifdef __cplusplus +//} +//#endif + +/* Microsoft Windows Extended data types */ +typedef struct sockaddr SOCKADDR; +typedef struct sockaddr *PSOCKADDR; +typedef struct sockaddr FAR *LPSOCKADDR; + +typedef struct sockaddr_in SOCKADDR_IN; +typedef struct sockaddr_in *PSOCKADDR_IN; +typedef struct sockaddr_in FAR *LPSOCKADDR_IN; + +typedef struct linger LINGER; +typedef struct linger *PLINGER; +typedef struct linger FAR *LPLINGER; + +typedef struct in_addr IN_ADDR; +typedef struct in_addr *PIN_ADDR; +typedef struct in_addr FAR *LPIN_ADDR; + +typedef struct fd_set FD_SET; +typedef struct fd_set *PFD_SET; +typedef struct fd_set FAR *LPFD_SET; + +typedef struct hostent HOSTENT; +typedef struct hostent *PHOSTENT; +typedef struct hostent FAR *LPHOSTENT; + +typedef struct servent SERVENT; +typedef struct servent *PSERVENT; +typedef struct servent FAR *LPSERVENT; + +typedef struct protoent PROTOENT; +typedef struct protoent *PPROTOENT; +typedef struct protoent FAR *LPPROTOENT; + +typedef struct timeval TIMEVAL; +typedef struct timeval *PTIMEVAL; +typedef struct timeval FAR *LPTIMEVAL; + +/* + * Windows message parameter composition and decomposition + * macros. + * + * WSAMAKEASYNCREPLY is intended for use by the Windows Sockets implementation + * when constructing the response to a WSAAsyncGetXByY() routine. + */ +//#define WSAMAKEASYNCREPLY(buflen,error) MAKELONG(buflen,error) +/* + * WSAMAKESELECTREPLY is intended for use by the Windows Sockets implementation + * when constructing the response to WSAAsyncSelect(). + */ +//#define WSAMAKESELECTREPLY(event,error) MAKELONG(event,error) +/* + * WSAGETASYNCBUFLEN is intended for use by the Windows Sockets application + * to extract the buffer length from the lParam in the response + * to a WSAGetXByY(). + */ +//#define WSAGETASYNCBUFLEN(lParam) LOWORD(lParam) +/* + * WSAGETASYNCERROR is intended for use by the Windows Sockets application + * to extract the error code from the lParam in the response + * to a WSAGetXByY(). + */ +//#define WSAGETASYNCERROR(lParam) HIWORD(lParam) +/* + * WSAGETSELECTEVENT is intended for use by the Windows Sockets application + * to extract the event code from the lParam in the response + * to a WSAAsyncSelect(). + */ +//#define WSAGETSELECTEVENT(lParam) LOWORD(lParam) +/* + * WSAGETSELECTERROR is intended for use by the Windows Sockets application + * to extract the error code from the lParam in the response + * to a WSAAsyncSelect(). + */ +//#define WSAGETSELECTERROR(lParam) HIWORD(lParam) + +//#endif /* _WINSOCKAPI_ */ + +!# +(provide "WINSOCK") \ No newline at end of file diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\clos.lisp corman\Sys\clos.lisp --- corman3\Sys\clos.lisp Mon Aug 28 16:17:52 2006 +++ corman\Sys\clos.lisp Thu Aug 31 11:12:02 2006 @@ -614,10 +614,17 @@ (defun (setf class-shared-slot-definitions) (new-value class) (setf (slot-value class 'shared-slot-definitions) new-value)) +(defun add-defclass-documentation (name options) + (dolist (o options) + (if (and o (eq (car o) :documentation)) + (let ((doc-string (princ-to-string (cdr o)))) + (setf (documentation name 'class) (subseq doc-string 1 (1- (length doc-string)))))))) + ;;; defclass (defmacro defclass (name direct-superclasses slot-definitions &rest options) + (add-defclass-documentation name options) `(ensure-class ',name :direct-superclasses ,(canonicalize-direct-superclasses direct-superclasses) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\debug.lisp corman\Sys\debug.lisp --- corman3\Sys\debug.lisp Wed Aug 30 15:36:38 2006 +++ corman\Sys\debug.lisp Thu Aug 31 11:13:41 2006 @@ -14,6 +14,7 @@ ; pl::peek-dword) (:export "FIND-SOURCE" + "WHERE-SOURCE" "DUMP-BYTES" "DUMP-DWORDS" "PEEK-BYTE" @@ -96,6 +97,20 @@ (ed file) (ide::set-selection file line 0 line 200) t)) + +(defun where-source (func) + (if (symbolp func) + (setq func (symbol-function func))) + (let* ((file (function-source-file func)) + (line (function-source-line func))) + (unless file + (format *terminal-io* "No source file information available.") + (return-from where-source nil)) + (when (pathnamep file) (setq file (namestring file))) + (if (is-relative-path file) + (setq file (concatenate 'string ccl:*cormanlisp-directory* "\\" file))) + (format t "~A is at ~A:~D~%" func file line)) + t) (defun display-character (n) (cond ((< n 32) #\.) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\defpackage.lisp corman\Sys\defpackage.lisp --- corman3\Sys\defpackage.lisp Wed Aug 30 15:36:30 2006 +++ corman\Sys\defpackage.lisp Thu Aug 31 11:26:21 2006 @@ -88,22 +88,51 @@ (setq sym (intern string package) package)) (export sym package)))) -(defun build-import-forms (into-pkg-name specification-list shadowing) +;; JK commented this out for the one below +;; (defun build-import-forms (into-pkg-name specification-list shadowing) + +;; (let (forms) +;; (when (symbolp into-pkg-name) +;; (setf into-pkg-name `',into-pkg-name)) +;; (do* ((still-to-process specification-list (cdr still-to-process)) +;; (spec (car still-to-process) (car still-to-process))) +;; ((null still-to-process) nil) +;; (let* ((package (canonical-package-name (car spec))) +;; (symbol-names (mapcan +;; #'(lambda (name) +;; (let ((sym (find-symbol (string name) package))) +;; (if sym +;; (list sym) +;; (progn (warn +;; "Symbol ~A was not found in the package named \"~A\" and will not be imported." +;; name package) nil)))) +;; (cdr spec)))) +;; (push `(,(if shadowing 'shadowing-import 'import) ',symbol-names ,into-pkg-name) forms))) +;; `(progn ,@forms))) + +;; JK - Turn build-import-forms into a macro to delay processing of the lookup of the symbols +;; Delaying the lookup allows defpackage to appear in an eval-when or let form + +(defmacro build-import-forms (into-pkg-name specification-list shadowing) + (let (forms) + (when (symbolp into-pkg-name) + (setf into-pkg-name `',into-pkg-name)) (do* ((still-to-process specification-list (cdr still-to-process)) (spec (car still-to-process) (car still-to-process))) ((null still-to-process) nil) - (let* ((package (canonical-package-name (car spec))) + (push `(let* ((package ',(canonical-package-name (car spec))) (symbol-names (mapcan #'(lambda (name) (let ((sym (find-symbol (string name) package))) (if sym (list sym) - (progn (warn - "Symbol ~A was not found in the package named \"~A\" and will not be imported." - name package) nil)))) - (cdr spec)))) - (push `(,(if shadowing 'shadowing-import 'import) ',symbol-names ,into-pkg-name) forms))) + (progn (warn "Symbol ~A was not found in package ~A and won't be imported." + name package) + nil)))) + (cdr ',spec)))) + (,(if shadowing 'shadowing-import 'import) symbol-names ,into-pkg-name)) forms)) +;; (push `(,(if shadowing 'shadowing-import 'import) symbol-names ,into-pkg-name) forms)) ; this works, but doesn't check for invalid symbols `(progn ,@forms))) ;;; @@ -156,15 +185,19 @@ :nicknames ',(remove-duplicates nicknames :test #'string-equal) :use nil ,@(when size `(:size ,size)))) forms)) - (setq use (mapcar (lambda (package) (package-name package)) use)) ;; list package names, not packages + (setq use (mapcar #'(lambda (package) (if (stringp package) package (package-name package))) use)) ;; list package names, not packages (when shadow (push `(shadow ',shadow ',name) forms)) (when shadowing-import-from - (push `,(build-import-forms name shadowing-import-from t) forms)) + (progn + ;(push `,(build-import-forms name shadowing-import-from t) forms))) jk commented out to use macro above + (push `(build-import-forms ',name ,shadowing-import-from t) forms))) (when use (push `(use-package ',use ',name) forms)) (when import-from - (push `,(build-import-forms name import-from nil) forms)) + (progn + ;(push `,(build-import-forms name import-from nil) forms)) jk commented out to use macro above + (push `(build-import-forms ',name ,import-from nil) forms))) (when intern (dolist (sym intern) (push `(intern ,sym ',name) forms))) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\ffi.lisp corman\Sys\ffi.lisp --- corman3\Sys\ffi.lisp Wed Aug 30 15:34:26 2006 +++ corman\Sys\ffi.lisp Thu Aug 31 11:27:56 2006 @@ -2132,13 +2132,15 @@ (setf (ct:cref (:wide-char *) buf i) (elt str i))))) (defun lisp-string-to-c-string (str &optional (cstr nil)) + (if str (let ((strlength (length str))) (unless cstr (setf cstr (ct:malloc (+ strlength 1)))) (dotimes (i strlength) (setf (ct:cref (:unsigned-char *) cstr i) (char-int (elt str i)))) (setf (ct:cref (:unsigned-char *) cstr strlength) 0) - cstr)) + cstr) + (create-foreign-ptr))) ;; Copy a lisp array of bytes to a C byte array. ;; If the optional parameter cbuf is not supplied (or is nil) then a new C byte diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\load-sys2.lisp corman\Sys\load-sys2.lisp --- corman3\Sys\load-sys2.lisp Wed Aug 30 15:33:14 2006 +++ corman\Sys\load-sys2.lisp Sun Oct 01 15:05:20 2006 @@ -86,6 +86,7 @@ (load-file "sys/sockets.lisp") (load-file "sys/xp.lisp") (load-file "sys/threads.lisp") +(load-file "sys/rmassage.lisp") (load-file "sys/auto-update.lisp") (load-file "sys/jumpmenu.lisp") (load-file "sys/ide-menus.lisp") diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\misc-utility.lisp corman\Sys\misc-utility.lisp --- corman3\Sys\misc-utility.lisp Wed Aug 30 15:32:10 2006 +++ corman\Sys\misc-utility.lisp Sun Oct 01 21:37:27 2006 @@ -302,14 +303,35 @@ :format-control format :format-arguments args)) +;; jk commented this out as it is broken by only taking into account the constituent character type +;; (set-dispatch-macro-character #\# #\: +;; #'(lambda (stream ch arg) +;; (declare (ignore arg ch)) +;; (do* ((c (%read-char stream)(%read-char stream)) +;; (char-type (readtable-char-type *readtable* c)(readtable-char-type *readtable* c)) +;; (chars '())) +;; ((not (eq char-type 'constituent-char-type)) +;; (progn (unread-char c stream) (make-symbol (concatenate 'string (nreverse chars))))) +;; (if (eq c #\:) +;; (cl::signal-reader-error "Invalid character #\: found in uninterned symbol")) +;; (push (char-upcase c) chars)))) + +;; jk redo the #: macro dispatch so that : is illegal in the iddle of a #:symbol +(defun set-readtable-char-type (readtable char value) + (let ((readtable-vector (readtable-table readtable))) + (setf (elt readtable-vector (* 2 (char-int char))) value))) + +(defsetf readtable-char-type set-readtable-char-type) + (set-dispatch-macro-character #\# #\: #'(lambda (stream ch arg) - (declare (ignore arg ch)) - (do* ((c (%read-char stream)(%read-char stream)) - (char-type (readtable-char-type *readtable* c)(readtable-char-type *readtable* c)) - (chars '())) - ((not (eq char-type 'constituent-char-type)) - (progn (unread-char c stream) (make-symbol (concatenate 'string (nreverse chars))))) - (if (eq c #\:) - (cl::signal-reader-error "Invalid character #\: found in uninterned symbol")) - (push (char-upcase c) chars)))) \ No newline at end of file + (declare (ignore ch arg)) + (let* (sym + (readtable *readtable*) + (char-type (readtable-char-type readtable #\:))) + (setf (readtable-char-type readtable #\:) 'illegal-char-type) + (handler-bind + ((simple-error #'(lambda (c) (setf (readtable-char-type readtable #\:) char-type)))) + (setf sym (read-expression stream t nil t nil nil))) + (setf (readtable-char-type readtable #\:) char-type) + sym))) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\misc.lisp corman\Sys\misc.lisp --- corman3\Sys\misc.lisp Wed Aug 30 15:32:20 2006 +++ corman\Sys\misc.lisp Thu Aug 31 12:23:38 2006 @@ -190,7 +190,7 @@ (letlist (let ((newlist nil)) (dolist (x form) - (when (and (consp x) (not (eq (car form) 'the))) + (when (and (consp x) (not (eq (car form) 'the)) (not (eq (car x) 'quote))) (push `(,(gensym) ,x) newlist))) (nreverse newlist))) (revlist diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\PACKAGE.LISP corman\Sys\package.lisp --- corman3\Sys\PACKAGE.LISP Wed Aug 30 15:32:00 2006 +++ corman\Sys\package.lisp Thu Aug 31 12:24:25 2006 @@ -238,7 +238,7 @@ ;;;; (defun delete-package (package) (declare (ignore package)) - (error "Not implemented")) + nil) ;; jk - changed this from (error "Not implemented.") to return nil for unsuccess ;;; ;;; Common Lisp IMPORT function. diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\READ.LISP corman\Sys\READ.LISP --- corman3\Sys\READ.LISP Wed Aug 30 15:30:34 2006 +++ corman\Sys\READ.LISP Sun Oct 01 18:15:03 2006 @@ -28,6 +28,8 @@ ;; (defvar *read-hook* nil) +(defvar *read-expression-number* 0) + (defconstant whitespace-char-type 0) (defconstant constituent-char-type 1) (defconstant terminating-macro-char-type 2) @@ -329,7 +331,7 @@ (symbol-set-special-flag sym))) (values sym state))) -(defun create-symbol-from-chars (chars) +(defun create-symbol-from-chars (chars &key (intern-symbol t)) (let ((package-chars nil) (symbol-chars nil) (package-markers 0) @@ -347,7 +349,9 @@ (let ((ch-list nil)) (dolist (x chars) (setq ch-list (cons (if (consp x) (car x) x) ch-list))) - (return-from create-symbol-from-chars (intern (coerce (nreverse ch-list) 'string) *package*)))) + (if intern-symbol + (return-from create-symbol-from-chars (intern (coerce (nreverse ch-list) 'string) *package*)) + (return-from create-symbol-from-chars (make-symbol (coerce (nreverse ch-list) 'string)))))) (do () ((null chars)) @@ -390,8 +394,12 @@ (if (and (eq state 'internal) (= package-markers 1) (not in-keyword-package)) (error "The symbol ~A is not exported by package ~A" symbol-name (package-name package)))) - (intern symbol-name package)) - (intern symbol-name *package*)))) + (if intern-symbol + (intern symbol-name package) + (make-symbol symbol-name))) + (if intern-symbol + (intern symbol-name *package*) + (make-symbol symbol-name))))) (defun whitespace-char (ch &optional (readtable *readtable*)) (eq (readtable-char-type readtable ch) 'whitespace-char-type)) @@ -641,7 +648,9 @@ (eof-error t) (eof-value nil) (recursive-p nil) - (interpret-numerically t)) + (interpret-numerically t) + (intern-symbol t)) + (unless (input-character-stream-p stream) (error "Expected an input character stream, got ~A" stream)) @@ -786,7 +794,7 @@ (if (and (eq (car token) #\.)(null (cdr token)) (not has-escape)) (setq ret dot-marker)) (if (null ret) - (setq ret (create-symbol-from-chars token))) + (setq ret (create-symbol-from-chars token :intern-symbol intern-symbol))) (return ret))))) (defvar *load-verbose* nil) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\readtable.lisp corman\Sys\readtable.lisp --- corman3\Sys\readtable.lisp Wed Aug 30 15:30:30 2006 +++ corman\Sys\readtable.lisp Sun Oct 01 15:15:06 2006 @@ -89,7 +89,8 @@ (defun set-macro-character (char function &optional (non-terminating-p nil) (readtable *readtable*)) (unless (readtablep readtable) (setq readtable *readtable*)) - (unless (functionp function) (error "Non-function passed to SET-MACRO-CHARACTER")) + (unless (or (null function) (functionp function)) + (error "Neither a function or nil was passed to SET-MACRO-CHARACTER")) ; jk added the or nil clause (let ((table (uref readtable readtable-table-offset)) (index (* (char-int char) 2))) (if non-terminating-p @@ -283,8 +284,9 @@ (set-dispatch-macro-character #\# #\: #'(lambda (stream ch arg) - (let* ((sym (read-expression stream t nil t nil))) - (make-symbol (symbol-name sym))))) + (declare (ignore ch arg)) + (let ((sym (read-expression stream t nil t nil nil))) + sym))) ;; faa20001128b - End change. ;(setq *readtable* (copy-readtable *common-lisp-readtable*)) @@ -332,6 +334,7 @@ (unread-char c stream) (setq startpos (stream-position stream)) (setq item (multiple-value-list (read-expression stream t nil t))) + ; (format t "read-expression returned: ~A~%" item) ; jk (if *read-hook* (funcall *read-hook* stream startpos (stream-position stream) (car item) (if item nil t))) @@ -462,7 +465,12 @@ (set-dispatch-macro-character #\# #\# #'(lambda (stream char int) - (make-eq-form-placeholder int))) + (declare (ignore stream char)) + (getf *read-eq-forms* int))) + +;; (set-dispatch-macro-character #\# #\# +;; #'(lambda (stream char int) +;; (make-eq-form-placeholder int))) (set-macro-character #\" #'(lambda (stream ch) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\rmassage.lisp corman\Sys\rmassage.lisp --- corman3\Sys\rmassage.lisp Wed Dec 31 16:00:00 1969 +++ corman\Sys\rmassage.lisp Sat Aug 26 11:08:49 2006 @@ -0,0 +1,257 @@ + +(in-package :common-lisp) + +;; redefine macroexpand-all and macroexpand-all-except-top to fix a bug +;; where macros and symbol-macros in a (function ...) form weren't being expanded +(defun macroexpand-all-except-top (x env) + (unless (consp x) (return-from macroexpand-all-except-top x)) + ;; now expand macros for each element of the form + (let ((sym (car x))) + (cond + ((eq sym 'LET) + (let* ((var-list (cadr x)) + (forms (cddr x)) + (*lexical-symbol-macros* *lexical-symbol-macros*) + (opt-declarations (find-opt-declarations forms))) + (if opt-declarations + (let ((cormanlisp::*compiler-optimize-speed* + cormanlisp::*compiler-optimize-speed*) + (cormanlisp::*compiler-optimize-safety* + cormanlisp::*compiler-optimize-safety*) + (cormanlisp::*compiler-optimize-debug* + cormanlisp::*compiler-optimize-debug*) + (cormanlisp::*compiler-optimize-space* + cormanlisp::*compiler-optimize-space*) + (cormanlisp::*compiler-optimize-compilation-speed* + cormanlisp::*compiler-optimize-compilation-speed*)) + (process-opt-declarations opt-declarations) + (rplaca (cdr x) (macroexpand-var-list var-list env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms)))) + (progn + (rplaca (cdr x) (macroexpand-var-list var-list env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))))) + ((eq sym 'LET*) + (let* ((var-list (cadr x)) + (forms (cddr x)) + (*lexical-symbol-macros* *lexical-symbol-macros*) + (opt-declarations (find-opt-declarations forms))) + (if opt-declarations + (let ((cormanlisp::*compiler-optimize-speed* + cormanlisp::*compiler-optimize-speed*) + (cormanlisp::*compiler-optimize-safety* + cormanlisp::*compiler-optimize-safety*) + (cormanlisp::*compiler-optimize-debug* + cormanlisp::*compiler-optimize-debug*) + (cormanlisp::*compiler-optimize-space* + cormanlisp::*compiler-optimize-space*) + (cormanlisp::*compiler-optimize-compilation-speed* + cormanlisp::*compiler-optimize-compilation-speed*)) + (process-opt-declarations opt-declarations) + (rplaca (cdr x) (macroexpand-var*-list var-list env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms)))) + (progn + (rplaca (cdr x) (macroexpand-var*-list var-list env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))))) + ((eq sym 'LAMBDA) +;; (print x) + (let* ((lambda-list (cadr x)) + (forms (cddr x)) + (*lexical-symbol-macros* *lexical-symbol-macros*) + (opt-declarations (find-opt-declarations forms))) + (if opt-declarations + (let ((cormanlisp::*compiler-optimize-speed* + cormanlisp::*compiler-optimize-speed*) + (cormanlisp::*compiler-optimize-safety* + cormanlisp::*compiler-optimize-safety*) + (cormanlisp::*compiler-optimize-debug* + cormanlisp::*compiler-optimize-debug*) + (cormanlisp::*compiler-optimize-space* + cormanlisp::*compiler-optimize-space*) + (cormanlisp::*compiler-optimize-compilation-speed* + cormanlisp::*compiler-optimize-compilation-speed*)) + (process-opt-declarations opt-declarations) + (rplaca (cdr x) (macroexpand-lambda-list lambda-list env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms)))) + (progn + (rplaca (cdr x) (macroexpand-lambda-list lambda-list env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))))) + ((eq sym 'QUOTE)) + ((eq sym 'FUNCTION) + (setf x (copy-tree-unquoted x)) ;; ensure unique source tree for each instance + (let ((func (cadr x)) + (forms (cddr x))) + (if (is-lambda-form func) + (progn +;; (let ((f (macroexpand-lambda-list func env))) +;; (print f)) + (rplaca (cdr x) (macroexpand-lambda-list func env)) +;; (do () +;; ((null forms)) +;; (rplaca forms (macroexpand-all (car forms) env)) +;; (setq forms (cdr forms)))))) + (push *lexical-macros* *collect-lexical-macros*) + (push func *collect-lexical-macros*) + (push *lexical-symbol-macros* *collect-lexical-symbol-macros*) + (push func *collect-lexical-symbol-macros*) + )))) ;; save for later + + ((eq sym 'MACROLET) + (let ((temp-macro-sym (gensym)) + (*lexical-macros* *lexical-macros*) + (macro-list (cadr x)) + (forms (cddr x))) + (dolist (m macro-list) + (eval `(defmacro ,temp-macro-sym ,(cadr m) ,@(cddr m))) + (push (list (car m) (symbol-function temp-macro-sym)) *lexical-macros*)) + (rplaca x 'let) + (rplaca (cdr x) 'nil) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))) + ((eq sym 'LABELS) + (let ((*lexical-macros* *lexical-macros*) + (func-list (cadr x)) + (forms (cddr x))) + ;; lexically defined functions need to shadow macros, + ;; so we add a macro definition with NIL as the function + ;; to disable the macro. + ;; shadow all the macros by adding the new function names + (dolist (m func-list) + (push (list (car m) nil) *lexical-macros*)) + ;; expand macros in functions + (do ((func func-list (cdr func))) + ((null func)) + (let ((func-forms (cddar func))) + (do ((i func-forms (cdr i))) + ((null i)) + (rplaca i (macroexpand-all (car i) env))))) + ;; expand body forms + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))) + ((eq sym 'FLET) + (let ((*lexical-macros* *lexical-macros*) + (func-list (cadr x)) + (forms (cddr x))) + ;; lexically defined functions need to shadow macros, + ;; so we add a macro definition with NIL as the function + ;; to disable the macro. + (dolist (m func-list) + (push (list (car m) nil) *lexical-macros*)) + ;; expand macros in functions + (do ((func func-list (cdr func))) + ((null func)) + (let ((func-forms (cddar func))) + (do ((i func-forms (cdr i))) + ((null i)) + (rplaca i (macroexpand-all (car i) env))))) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))) + ((eq sym 'SYMBOL-MACROLET) + (let ((*lexical-symbol-macros* *lexical-symbol-macros*) + (macro-list (cadr x)) + (forms (cddr x))) + (dolist (m macro-list) + (push (list (car m) (cadr m)) *lexical-symbol-macros*)) + (rplaca x 'progn) + (rplaca (cdr x) 'nil) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))) + + ((or (eq sym 'BLOCK)(eq sym 'RETURN-FROM)) + (do ((forms (cddr x) (cdr forms))) + ((endp forms)) + (rplaca forms (macroexpand-all (car forms) env)))) + + ((eq sym 'TAGBODY) + (do ((forms (cdr x) (cdr forms))) + ((endp forms)) + (unless (or (integerp (car forms))(symbolp (car forms))) + (rplaca forms (macroexpand-all (car forms) env))))) + + ((eq sym 'GO)) + ((eq sym 'DECLARE)) + + ;; SETQ on SYMBOL-MACROLET'ted symbols must be SETF, so be careful... + ((and (eq sym 'SETQ) (%nfixup-setq-lexical-symbol-macros (cdr x) env)) + (rplaca x 'SETF) + (setq x (macroexpand-all x env))) + ;; ...and same is true for PSETQ. -- Vassili 12/15/1998 + ((and (eq sym 'PSETQ) (%nfixup-setq-lexical-symbol-macros (cdr x) env)) + (rplaca x 'PSETF) + (setq x (macroexpand-all x env))) + ((eq sym 'SETQ) + (do ((forms (cddr x) (cddr forms))) + ((endp forms)) + (rplaca forms (macroexpand-all (car forms) env)))) + + ((is-lambda-form sym) + (let ((forms (cdr x))) + (rplaca x (macroexpand-all-except-top sym env)) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))) + (t + (let ((forms (cdr x))) + (do () + ((null forms)) + (rplaca forms (macroexpand-all (car forms) env)) + (setq forms (cdr forms))))))) + x) + +(defun macroexpand-all (x &optional env) + (if (and (consp x) (eq (car x) 'quote)) + (return-from macroexpand-all x)) + + ;; keep doing compiler macros, macros and inline expansion + ;; until we go one time through the loop and nothing changes + (do ((save x x)) + (nil) + (setq x (expand-compiler-macros x)) + (setq x (macroexpand x env)) ;; expand top level form + (setq x (inline-expand x env)) + (if (eq save x) + (return))) + (if (compiler-fold-constants) + (if (constantp x) + (let ((result (eval-constant-expression x))) + (if (or (consp result) + (and (symbolp result) + (not (keywordp result)) + (not (eq result t)) + (not (eq result nil)))) + (setf result (list 'quote result))) + (return-from macroexpand-all result)))) + (macroexpand-all-except-top x env)) + +(defun macroexpand-diag (x &optional env) + (format t "*collect-lexical-macros* before: ~A~%" *collect-lexical-macros*) + (format t "*collect-lexical-symbol-macros* before: ~A~%" *collect-lexical-symbol-macros*) + (macroexpand-all x env) + (format t "*collect-lexical-macros* after: ~A~%" *collect-lexical-macros*) + (format t "*collect-lexical-symbol-macros* after: ~A~%" *collect-lexical-symbol-macros*)) diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\Sys\temp.lisp corman\Sys\temp.lisp --- corman3\Sys\temp.lisp Wed Dec 31 16:00:00 1969 +++ corman\Sys\temp.lisp Mon Jul 31 07:33:20 2006 @@ -0,0 +1,42 @@ +;;;; ------------------------------- +;;;; Copyright (c) 2000-2003 Corman Technologies +;;;; All rights reserved. +;;;; ------------------------------- +(let ((th-message "The object ~A is not of type ~A")) + +(defmacro the (type object) + (let ((t1 (gensym)) + (t2 (gensym))) + `(let ((,t1 ',type) + (,t2 ,object)) + (if (typep ,t2 ,t1) + ,t2 + (error th-message ,t2 ,t1))))) + +) + +(defun equal (x y) + (if (and (consp x) (consp y) (eql (car x) (car y)) (equal (cdr x) (cdr y))) + t + (eql x y))) + +(defun makeset (lat) + (cond ((null lat) ()) + ((member (car lat)(cdr lat) :test #'equal)(makeset (cdr lat))) + (t (cons (car lat)(makeset (cdr lat)))))) + +(defun combinations (size set) + (cond ((zerop size) '(())) + ((null set) ()) + (t (append (distrib (car set) (combinations (1- size) (cdr set))) + (combinations size (cdr set)))))) + +(defun distrib (a sett) + (cond ((null sett) ()) + (t (cons (cons a (car sett)) (distrib a (cdr sett)))))) +(room) +(mapcar #'print (makeset (combinations 9 '(red red red green green green white white white + blue blue blue)))) + +(room) + diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\utilities\install-hyperspec.lisp corman\utilities\install-hyperspec.lisp --- corman3\utilities\install-hyperspec.lisp Wed Dec 31 16:00:00 1969 +++ corman\utilities\install-hyperspec.lisp Thu Dec 23 18:29:34 2004 @@ -0,0 +1,106 @@ +;;;; +;;;; File: install-hyperspec.lisp +;;;; Contents: Hyperspec installation utility for Corman Lisp. +;;;; History: 4/9/02 RGC Created. +;;;; +;;;; Load this file to install the Hyperspec. +;;;; + +(in-package :win32) + +#! (:export t :library "KERNEL32") + +/* + * Standard Archive Format - Standard TAR - USTAR + */ + +#define RECORDSIZE 512 +#define NAMSIZ 100 +#define TUNMLEN 32 +#define TGNMLEN 32 + +typedef struct _header +{ + char name[NAMSIZ]; + char mode[8]; + char uid[8]; + char gid[8]; + char size[12]; + char mtime[12]; + char chksum[8]; + char linkflag; + char linkname[NAMSIZ]; + char magic[8]; + char uname[TUNMLEN]; + char gname[TGNMLEN]; + char devmajor[8]; + char devminor[8]; +} header; +!# + +(defun tar-extract (path) + (multiple-value-bind (address length) + (ccl:map-file path) + (if (null address) + (error "Could not find file ~S" path)) + (unwind-protect + (do ((pos 0) + (file-name nil) + (header nil) + (addr (ct:foreign-ptr-to-int address)) + (file-length 0) + (file-path) + (root (make-pathname :device (pathname-device path) :directory (pathname-directory path)))) + ((>= pos length)) + (setf header (ct:int-to-foreign-ptr (+ addr pos))) + (setf file-name + (ct:c-string-to-lisp-string (ct:cref header header name))) + (if (or (null file-name) (= (length file-name) 0)) + (return)) + (setf file-path (merge-pathnames file-name root)) + (setf file-length + (parse-integer (ct:c-string-to-lisp-string (ct:cref header header size)) + :junk-allowed t + :radix 8)) + (format t "~A~20T~D~%" file-name file-length) (force-output) + (ensure-directories-exist file-path) + (if (pathname-name file-path) + (with-open-file (os file-path :direction :output :element-type 'unsigned-byte) + (dotimes (i file-length) + (write-byte (ct:cref (:unsigned-char *) address (+ pos RECORDSIZE i)) os)))) + (incf pos (* (+ 1 (truncate (+ file-length (- RECORDSIZE 1)) RECORDSIZE)) RECORDSIZE)))) + (ccl:unmap-file address))) + +(defun install-hyperspec () + (if (eq (win:message-box-yes-no "Do you want to install the Common Lisp HyperSpec (from Xanalys)?" + "Install Common Lisp HyperSpec") 'win:idyes) + (let ((gzpath (namestring (truename (merge-pathnames "HyperSpec-6-0.tar.gz")))) + (tarpath (namestring (truename (merge-pathnames "HyperSpec-6-0.tar")))) + (hyperspec-path (namestring (truename (merge-pathnames "hyperspec/"))))) + + ;; unless the Hyperspec is already installed at this location, extract + ;; it to that location + (unless (probe-file (merge-pathnames "Front\\Contents.htm" hyperspec-path)) + (format t "Unzipping ~A...~%" gzpath) + (force-output) + (ccl:uncompress-file gzpath tarpath) + (format t "Extracting files from ~A...~%" tarpath) + (tar-extract tarpath)) + + (with-open-file (init-file (merge-pathnames "init.lisp") :direction :output :if-exists :append) + (format init-file "~%;;; Set the Hyperspec path~%(setf *hyperspec-local-path* ~S)~%" + hyperspec-path)) + (setf *hyperspec-local-path* hyperspec-path)) + (let () + (with-open-file (init-file (merge-pathnames "init.lisp") :direction :output :if-exists :append) + (format init-file "~%;;; Set the Hyperspec path~%(setf *hyperspec-local-path* nil)~%")) + (setf *hyperspec-local-path* nil)))) + +(install-hyperspec) + + + + + + + \ No newline at end of file Binary files corman3\zlib\bin\compress.obj and corman\zlib\bin\compress.obj differ Binary files corman3\zlib\bin\deflate.obj and corman\zlib\bin\deflate.obj differ Binary files corman3\zlib\bin\gzio.obj and corman\zlib\bin\gzio.obj differ Binary files corman3\zlib\bin\infblock.obj and corman\zlib\bin\infblock.obj differ Binary files corman3\zlib\bin\infcodes.obj and corman\zlib\bin\infcodes.obj differ Binary files corman3\zlib\bin\inffast.obj and corman\zlib\bin\inffast.obj differ Binary files corman3\zlib\bin\inflate.obj and corman\zlib\bin\inflate.obj differ Binary files corman3\zlib\bin\inftrees.obj and corman\zlib\bin\inftrees.obj differ Binary files corman3\zlib\bin\infutil.obj and corman\zlib\bin\infutil.obj differ Binary files corman3\zlib\bin\minigzip.obj and corman\zlib\bin\minigzip.obj differ Binary files corman3\zlib\bin\trees.obj and corman\zlib\bin\trees.obj differ Binary files corman3\zlib\bin\uncompr.obj and corman\zlib\bin\uncompr.obj differ Binary files corman3\zlib\bin\zadler32.obj and corman\zlib\bin\zadler32.obj differ Binary files corman3\zlib\bin\zcrc32.obj and corman\zlib\bin\zcrc32.obj differ Binary files corman3\zlib\bin\zutil.obj and corman\zlib\bin\zutil.obj differ diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\doc\algorithm.doc corman\zlib\doc\algorithm.doc --- corman3\zlib\doc\algorithm.doc Wed Dec 31 16:00:00 1969 +++ corman\zlib\doc\algorithm.doc Mon Jul 31 07:33:08 2006 @@ -0,0 +1,213 @@ +1. Compression algorithm (deflate) + +The deflation algorithm used by gzip (also zip and zlib) is a variation of +LZ77 (Lempel-Ziv 1977, see reference below). It finds duplicated strings in +the input data. The second occurrence of a string is replaced by a +pointer to the previous string, in the form of a pair (distance, +length). Distances are limited to 32K bytes, and lengths are limited +to 258 bytes. When a string does not occur anywhere in the previous +32K bytes, it is emitted as a sequence of literal bytes. (In this +description, `string' must be taken as an arbitrary sequence of bytes, +and is not restricted to printable characters.) + +Literals or match lengths are compressed with one Huffman tree, and +match distances are compressed with another tree. The trees are stored +in a compact form at the start of each block. The blocks can have any +size (except that the compressed data for one block must fit in +available memory). A block is terminated when deflate() determines that +it would be useful to start another block with fresh trees. (This is +somewhat similar to the behavior of LZW-based _compress_.) + +Duplicated strings are found using a hash table. All input strings of +length 3 are inserted in the hash table. A hash index is computed for +the next 3 bytes. If the hash chain for this index is not empty, all +strings in the chain are compared with the current input string, and +the longest match is selected. + +The hash chains are searched starting with the most recent strings, to +favor small distances and thus take advantage of the Huffman encoding. +The hash chains are singly linked. There are no deletions from the +hash chains, the algorithm simply discards matches that are too old. + +To avoid a worst-case situation, very long hash chains are arbitrarily +truncated at a certain length, determined by a runtime option (level +parameter of deflateInit). So deflate() does not always find the longest +possible match but generally finds a match which is long enough. + +deflate() also defers the selection of matches with a lazy evaluation +mechanism. After a match of length N has been found, deflate() searches for +a longer match at the next input byte. If a longer match is found, the +previous match is truncated to a length of one (thus producing a single +literal byte) and the process of lazy evaluation begins again. Otherwise, +the original match is kept, and the next match search is attempted only N +steps later. + +The lazy match evaluation is also subject to a runtime parameter. If +the current match is long enough, deflate() reduces the search for a longer +match, thus speeding up the whole process. If compression ratio is more +important than speed, deflate() attempts a complete second search even if +the first match is already long enough. + +The lazy match evaluation is not performed for the fastest compression +modes (level parameter 1 to 3). For these fast modes, new strings +are inserted in the hash table only when no match was found, or +when the match is not too long. This degrades the compression ratio +but saves time since there are both fewer insertions and fewer searches. + + +2. Decompression algorithm (inflate) + +2.1 Introduction + +The real question is, given a Huffman tree, how to decode fast. The most +important realization is that shorter codes are much more common than +longer codes, so pay attention to decoding the short codes fast, and let +the long codes take longer to decode. + +inflate() sets up a first level table that covers some number of bits of +input less than the length of longest code. It gets that many bits from the +stream, and looks it up in the table. The table will tell if the next +code is that many bits or less and how many, and if it is, it will tell +the value, else it will point to the next level table for which inflate() +grabs more bits and tries to decode a longer code. + +How many bits to make the first lookup is a tradeoff between the time it +takes to decode and the time it takes to build the table. If building the +table took no time (and if you had infinite memory), then there would only +be a first level table to cover all the way to the longest code. However, +building the table ends up taking a lot longer for more bits since short +codes are replicated many times in such a table. What inflate() does is +simply to make the number of bits in the first table a variable, and set it +for the maximum speed. + +inflate() sends new trees relatively often, so it is possibly set for a +smaller first level table than an application that has only one tree for +all the data. For inflate, which has 286 possible codes for the +literal/length tree, the size of the first table is nine bits. Also the +distance trees have 30 possible values, and the size of the first table is +six bits. Note that for each of those cases, the table ended up one bit +longer than the ``average'' code length, i.e. the code length of an +approximately flat code which would be a little more than eight bits for +286 symbols and a little less than five bits for 30 symbols. It would be +interesting to see if optimizing the first level table for other +applications gave values within a bit or two of the flat code size. + + +2.2 More details on the inflate table lookup + +Ok, you want to know what this cleverly obfuscated inflate tree actually +looks like. You are correct that it's not a Huffman tree. It is simply a +lookup table for the first, let's say, nine bits of a Huffman symbol. The +symbol could be as short as one bit or as long as 15 bits. If a particular +symbol is shorter than nine bits, then that symbol's translation is duplicated +in all those entries that start with that symbol's bits. For example, if the +symbol is four bits, then it's duplicated 32 times in a nine-bit table. If a +symbol is nine bits long, it appears in the table once. + +If the symbol is longer than nine bits, then that entry in the table points +to another similar table for the remaining bits. Again, there are duplicated +entries as needed. The idea is that most of the time the symbol will be short +and there will only be one table look up. (That's whole idea behind data +compression in the first place.) For the less frequent long symbols, there +will be two lookups. If you had a compression method with really long +symbols, you could have as many levels of lookups as is efficient. For +inflate, two is enough. + +So a table entry either points to another table (in which case nine bits in +the above example are gobbled), or it contains the translation for the symbol +and the number of bits to gobble. Then you start again with the next +ungobbled bit. + +You may wonder: why not just have one lookup table for how ever many bits the +longest symbol is? The reason is that if you do that, you end up spending +more time filling in duplicate symbol entries than you do actually decoding. +At least for deflate's output that generates new trees every several 10's of +kbytes. You can imagine that filling in a 2^15 entry table for a 15-bit code +would take too long if you're only decoding several thousand symbols. At the +other extreme, you could make a new table for every bit in the code. In fact, +that's essentially a Huffman tree. But then you spend two much time +traversing the tree while decoding, even for short symbols. + +So the number of bits for the first lookup table is a trade of the time to +fill out the table vs. the time spent looking at the second level and above of +the table. + +Here is an example, scaled down: + +The code being decoded, with 10 symbols, from 1 to 6 bits long: + +A: 0 +B: 10 +C: 1100 +D: 11010 +E: 11011 +F: 11100 +G: 11101 +H: 11110 +I: 111110 +J: 111111 + +Let's make the first table three bits long (eight entries): + +000: A,1 +001: A,1 +010: A,1 +011: A,1 +100: B,2 +101: B,2 +110: -> table X (gobble 3 bits) +111: -> table Y (gobble 3 bits) + +Each entry is what the bits decode to and how many bits that is, i.e. how +many bits to gobble. Or the entry points to another table, with the number of +bits to gobble implicit in the size of the table. + +Table X is two bits long since the longest code starting with 110 is five bits +long: + +00: C,1 +01: C,1 +10: D,2 +11: E,2 + +Table Y is three bits long since the longest code starting with 111 is six +bits long: + +000: F,2 +001: F,2 +010: G,2 +011: G,2 +100: H,2 +101: H,2 +110: I,3 +111: J,3 + +So what we have here are three tables with a total of 20 entries that had to +be constructed. That's compared to 64 entries for a single table. Or +compared to 16 entries for a Huffman tree (six two entry tables and one four +entry table). Assuming that the code ideally represents the probability of +the symbols, it takes on the average 1.25 lookups per symbol. That's compared +to one lookup for the single table, or 1.66 lookups per symbol for the +Huffman tree. + +There, I think that gives you a picture of what's going on. For inflate, the +meaning of a particular symbol is often more than just a letter. It can be a +byte (a "literal"), or it can be either a length or a distance which +indicates a base value and a number of bits to fetch after the code that is +added to the base value. Or it might be the special end-of-block code. The +data structures created in inftrees.c try to encode all that information +compactly in the tables. + + +Jean-loup Gailly Mark Adler +jloup@gzip.org madler@alumni.caltech.edu + + +References: + +[LZ77] Ziv J., Lempel A., ``A Universal Algorithm for Sequential Data +Compression,'' IEEE Transactions on Information Theory, Vol. 23, No. 3, +pp. 337-343. + +``DEFLATE Compressed Data Format Specification'' available in +ftp://ds.internic.net/rfc/rfc1951.txt diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\doc\deflate-1.3.doc corman\zlib\doc\deflate-1.3.doc --- corman3\zlib\doc\deflate-1.3.doc Wed Dec 31 16:00:00 1969 +++ corman\zlib\doc\deflate-1.3.doc Mon Jul 31 07:33:08 2006 @@ -0,0 +1,884 @@ + + + + + + +INTERNET-DRAFT L. P. Deutsch +DEFLATE 1.3 Aladdin Enterprises +Expires: 24 July 1996 24 Jan 1996 + +DEFLATE Compressed Data Format Specification version 1.3 + +File draft-deutsch-deflate-1.3-00.txt + +Status of this Memo + + This document is an Internet-Draft. Internet-Drafts are working + documents of the Internet Engineering Task Force (IETF), its areas, + and its working groups. Note that other groups may also distribute + working documents as Internet-Drafts. + + Internet-Drafts are draft documents valid for a maximum of six months + and may be updated, replaced, or obsoleted by other documents at any + time. It is inappropriate to use Internet- Drafts as reference + material or to cite them other than as ``work in progress.'' + + To learn the current status of any Internet-Draft, please check the + ``1id-abstracts.txt'' listing contained in the Internet- Drafts + Shadow Directories on ftp.is.co.za (Africa), nic.nordu.net (Europe), + munnari.oz.au (Pacific Rim), ds.internic.net (US East Coast), or + ftp.isi.edu (US West Coast). + + Distribution of this memo is unlimited. + + Notices + + Copyright (C) 1995 L. Peter Deutsch + + Permission is granted to copy and distribute this document for any + purpose and without charge, including translations into other + languages and incorporation into compilations, provided that it is + copied as a whole (including the copyright notice and this notice) + and with no changes. + +Abstract + + This specification defines a lossless compressed data format that + compresses data using a combination of the LZ77 algorithm and Huffman + coding, with efficiency comparable to the best currently available + general-purpose compression methods. The data can be produced or + consumed, even for an arbitrarily long sequentially presented input + data stream, using only an a priori bounded amount of intermediate + storage. The format can be implemented readily in a manner not + covered by patents. + + + +Deutsch [Page 1] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + +Table of Contents + + 1. Introduction ................................................... 2 + 1.1 Purpose .................................................... 2 + 1.2 Intended audience .......................................... 3 + 1.3 Scope ...................................................... 3 + 1.4 Compliance ................................................. 3 + 1.5 Definitions of terms and conventions used ................. 4 + 1.6 Changes from previous versions ............................. 4 + 2. Compressed representation overview ............................. 4 + 3. Detailed specification ......................................... 4 + 3.1 Overall conventions ........................................ 4 + 3.1.1. Packing into bytes .................................. 5 + 3.2 Compressed block format .................................... 6 + 3.2.1. Synopsis of prefix and Huffman coding ............... 6 + 3.2.2. Use of Huffman coding in the 'deflate' format ....... 7 + 3.2.3. Details of block format ............................. 9 + 3.2.4. Non-compressed blocks (BTYPE=00) ................... 10 + 3.2.5. Compressed blocks (length and distance codes) ...... 10 + 3.2.6. Compression with fixed Huffman codes (BTYPE=01) .... 11 + 3.2.7. Compression with dynamic Huffman codes (BTYPE=10) .. 11 + 3.3 Compliance ................................................ 13 + 4. Compression algorithm details ................................. 13 + 5. References .................................................... 14 + 6. Security considerations ....................................... 14 + 7. Source code ................................................... 15 + 8. Acknowledgements .............................................. 15 + 9. Author's address .............................................. 15 + +1. Introduction + + 1.1. Purpose + + The purpose of this specification is to define a lossless + compressed data format that: + + o Is independent of CPU type, operating system, file system, + and character set, and hence can be used for interchange; + o Can be produced or consumed, even for an arbitrarily long + sequentially presented input data stream, using only an a + priori bounded amount of intermediate storage, and hence can + be used in data communications or similar structures such as + Unix filters; + o Compresses data with efficiency comparable to the best + currently available general-purpose compression methods, and + in particular considerably better than the 'compress' + program; + o Can be implemented readily in a manner not covered by + patents, and hence can be practiced freely; + o Is compatible with the file format produced by the current + widely used gzip utility, in that conforming decompressors + will be able to read data produced by the existing gzip + + +Deutsch [Page 2] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + compressor. + + The data format defined by this specification does not attempt to: + + o Allow random access to compressed data; + o Compress specialized data (e.g., raster graphics) as well as + the best currently available specialized algorithms. + + A simple counting argument shows that no lossless compression + algorithm can compress every possible input data set. For the + format defined here, the worst case expansion is 5 bytes per 32K- + byte block, i.e., a size increase of 0.015% for large data sets. + English text usually compresses by a factor of 2.5 to 3; + executable files usually compress somewhat less; graphical data + such as raster images may compress much more. + + 1.2. Intended audience + + This specification is intended for use by implementors of software + to compress data into 'deflate' format and/or decompress data from + 'deflate' format. + + The text of the specification assumes a basic background in + programming at the level of bits and other primitive data + representations. Familiarity with the technique of Huffman coding + is helpful but not required. + + 1.3. Scope + + The specification specifies a method for representing a sequence + of bytes as a (usually shorter) sequence of bits, and a method for + packing the latter bit sequence into bytes. + + 1.4. Compliance + + Unless otherwise indicated below, a compliant decompressor must be + able to accept and decompress any data set that conforms to all + the specifications presented here; a compliant compressor must + produce data sets that conform to all the specifications presented + here. + + 1.5. Definitions of terms and conventions used + + byte: 8 bits stored or transmitted as a unit (same as an octet). + (For this specification, a byte is exactly 8 bits, even on + machines which store a character on a number of bits different + from 8.) See Section 3.1, below, for the numbering of bits within + a byte. + + string: a sequence of arbitrary bytes. + + 1.6. Changes from previous versions + + +Deutsch [Page 3] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + There have been no technical changes to the deflate format since + version 1.1 of this specification. In version 1.2, some + terminology was changed. Version 1.3 is a conversion of the + specification to Internet Draft style. + +2. Compressed representation overview + + A compressed data set consists of a series of blocks, corresponding + to successive blocks of input data. The block sizes are arbitrary, + except that non-compressible blocks are limited to 65,535 bytes. + + Each block is compressed using a combination of the LZ77 algorithm + and Huffman coding. The Huffman trees for each block are independant + of those for previous or subsequent blocks; the LZ77 algorithm may + use a reference to a duplicated string occurring in a previous block, + up to 32K input bytes before. + + Each block consists of two parts: a pair of Huffman code trees that + describe the representation of the compressed data part, and a + compressed data part. (The Huffman trees themselves are compressed + using Huffman encoding.) The compressed data consists of a series of + elements of two types: literal bytes (of strings that have not been + detected as duplicated within the previous 32K input bytes), and + pointers to duplicated strings, where a pointer is represented as a + pair . The representation used in the + 'deflate' format limits distances to 32K bytes and lengths to 258 + bytes, but does not limit the size of a block, except for + uncompressible blocks, which are limited as noted above. + + Each type of value (literals, distances, and lengths) in the + compressed data is represented using a Huffman code, using one code + tree for literals and lengths and a separate code tree for distances. + The code trees for each block appear in a compact form just before + the compressed data for that block. + +3. Detailed specification + + 3.1. Overall conventions In the diagrams below, a box like this: + + +---+ + | | <-- the vertical bars might be missing + +---+ + + represents one byte; a box like this: + + +==============+ + | | + +==============+ + + represents a variable number of bytes. + + Bytes stored within a computer do not have a 'bit order', since + + +Deutsch [Page 4] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + they are always treated as a unit. However, a byte considered as + an integer between 0 and 255 does have a most- and least- + significant bit, and since we write numbers with the most- + significant digit on the left, we also write bytes with the most- + significant bit on the left. In the diagrams below, we number the + bits of a byte so that bit 0 is the least-significant bit, i.e., + the bits are numbered: + + +--------+ + |76543210| + +--------+ + + Within a computer, a number may occupy multiple bytes. All + multi-byte numbers in the format described here are stored with + the least-significant byte first (at the lower memory address). + For example, the decimal number 520 is stored as: + + 0 1 + +--------+--------+ + |00001000|00000010| + +--------+--------+ + ^ ^ + | | + | + more significant byte = 2 x 256 + + less significant byte = 8 + + 3.1.1. Packing into bytes + + This document does not address the issue of the order in which + bits of a byte are transmitted on a bit-sequential medium, + since the final data format described here is byte- rather than + bit-oriented. However, we describe the compressed block format + in Section 3.2, below, as a sequence of data elements of + various bit lengths, not a sequence of bytes. We must + therefore specify how to pack these data elements into bytes to + form the final compressed byte sequence: + + o Data elements are packed into bytes in order of + increasing bit number within the byte, i.e., starting + with the least- significant bit of the byte. + o Data elements other than Huffman codes are packed + starting with the least-significant bit of the data + element. + o Huffman codes are packed starting with the most- + significant bit of the code. + + In other words, if one were to print out the compressed data as + a sequence of bytes, starting with the first byte at the + *right* margin and proceeding to the *left*, with the most- + significant bit of each byte on the left as usual, one would be + able to parse the result from right to left, with fixed-width + elements in the correct MSB-to-LSB order and Huffman codes in + + +Deutsch [Page 5] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + bit-reversed order (i.e., with the first bit of the code in the + relative LSB position). + + 3.2. Compressed block format + + 3.2.1. Synopsis of prefix and Huffman coding + + Prefix coding represents symbols from an a priori known + alphabet by bit sequences (codes), one code for each symbol, in + a manner such that different symbols may be represented by bit + sequences of different lengths, but a parser can always parse + an encoded string unambiguously symbol-by-symbol. + + We define a prefix code in terms of a binary tree in which the + two edges descending from each non-leaf node are labeled 0 and + 1 and in which the leaf nodes correspond one-for-one with (are + labeled with) the symbols of the alphabet; then the code for a + symbol is the sequence of 0's and 1's on the edges leading from + the root to the leaf labeled with that symbol. For example: + + /\ Symbol Code + 0 1 ------ ---- + / \ A 00 + /\ B B 1 + 0 1 C 011 + / \ D 010 + A /\ + 0 1 + / \ + D C + + A parser can decode the next symbol from an encoded input + stream by walking down the tree from the root, at each step + choosing the edge corresponding to the next input bit. + + Given an alphabet with known symbol frequencies, the Huffman + algorithm allows the construction of an optimal prefix code + (one which represents strings with those symbol frequencies + using the fewest bits of any possible prefix codes for that + alphabet). Such a code is called a Huffman code. (See + reference [HUFFMAN] in Chapter 5, references for additional + information on Huffman codes.) + + Note that in the 'deflate' format, the Huffman codes for the + various alphabets must not exceed certain maximum code lengths. + This constraint complicates the algorithm for computing code + lengths from symbol frequencies. Again, see Chapter 5, + references for details. + + 3.2.2. Use of Huffman coding in the 'deflate' format + + The Huffman codes used for each alphabet in the 'deflate' + + +Deutsch [Page 6] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + format have two additional rules: + + o All codes of a given bit length have lexicographically + consecutive values, in the same order as the symbols they + represent; + + o Shorter codes lexicographically precede longer codes. + + We could recode the example above to follow this rule as + follows, assuming that the order of the alphabet is ABCD: + + Symbol Code + ------ ---- + A 10 + B 0 + C 110 + D 111 + + I.e., 0 precedes 10 which precedes 11x, and 110 and 111 are + lexicographically consecutive. + + Given this rule, we can define the Huffman code for an alphabet + just by giving the bit lengths of the codes for each symbol of + the alphabet in order; this is sufficient to determine the + actual codes. In our example, the code is completely defined + by the sequence of bit lengths (2, 1, 3, 3). The following + algorithm generates the codes as integers, intended to be read + from most- to least-significant bit. The code lengths are + initially in tree[I].Len; the codes are produced in + tree[I].Code. + + 1) Count the number of codes for each code length. Let + bl_count[N] be the number of codes of length N, N >= 1. + + 2) Find the numerical value of the smallest code for each code + length: + + code = 0; + bl_count[0] = 0; + for (bits = 1; bits <= MAX_BITS; bits++) { + next_code[bits] = code + = (code + bl_count[bits-1]) << 1; + } + + 3) Assign numerical values to all codes, using consecutive + values for all codes of the same length with the base values + determined at step 2. Codes that are never used (which have a + bit length of zero) must not be assigned a value. + + for (n = 0; n <= max_code; n++) { + len = tree[n].Len; + if (len == 0) continue; + + +Deutsch [Page 7] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + tree[n].Code = next_code[len]++; + } + + Example: + + Consider the alphabet ABCDEFGH, with bit lengths (3, 3, 3, 3, + 3, 2, 4, 4). After step 1, we have: + + N bl_count[N] + - ----------- + 2 1 + 3 5 + 4 2 + + Step 2 computes the following next_code values: + + N next_code[N] + - ------------ + 1 0 + 2 0 + 3 2 + 4 14 + + Step 3 produces the following code values: + + Symbol Length Code + ------ ------ ---- + A 3 010 + B 3 011 + C 3 100 + D 3 101 + E 3 110 + F 2 00 + G 4 1110 + H 4 1111 + + 3.2.3. Details of block format + + Each block of compressed data begins with 3 header bits + containing the following data: + + first bit BFINAL + next 2 bits BTYPE + + Note that the header bits do not necessarily begin on a byte + boundary, since a block does not necessarily occupy an integral + number of bytes. + + BFINAL is set iff this is the last block of the data set. + + + + + +Deutsch [Page 8] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + BTYPE specifies how the data are compressed, as follows: + + 00 - no compression + 01 - compressed with fixed Huffman codes + 10 - compressed with dynamic Huffman codes + 11 - reserved (error) + + The only difference between the two compressed cases is how the + Huffman codes for the literal/length and distance alphabets are + defined. + + In all cases, the decoding algorithm for the actual data is as + follows: + + do + read block header from input stream. + if stored with no compression + skip any remaining bits in current partially + processed byte + read LEN and NLEN (see next section) + copy LEN bytes of data to output + otherwise + if compressed with dynamic Huffman codes + read representation of code trees (see + subsection below) + loop (until end of block code recognized) + decode literal/length value from input stream + if value < 256 + copy value (literal byte) to output stream + otherwise + if value = end of block (256) + break from loop + otherwise (value = 257..285) + decode distance from input stream + + move backwards distance bytes in the output + stream, and copy length bytes from this + position to the output stream. + end loop + while not last block + + Note that a duplicated string reference may refer to a string + in a previous block; i.e., the backward distance may cross one + or more block boundaries. However a distance cannot refer past + the beginning of the output stream. Note also that the + referenced string may overlap the current position; for + example, if the last 2 bytes decoded have values X and Y, a + string reference with adds X,Y,X,Y,X + to the output stream. + + We now specify each compression method in turn. + + + +Deutsch [Page 9] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + 3.2.4. Non-compressed blocks (BTYPE=00) + + Any bits of input up to the next byte boundary are ignored. + The rest of the block consists of the following information: + + 0 1 2 3 4... + +---+---+---+---+=================================+ + | LEN | NLEN |... LEN bytes of literal data...| + +---+---+---+---+=================================+ + + LEN is the number of data bytes in the block. NLEN is the + one's complement of LEN. + + 3.2.5. Compressed blocks (length and distance codes) + + As noted above, encoded data blocks in the 'deflate' format + consist of sequences of symbols drawn from three conceptually + distinct alphabets: either literal bytes, from the alphabet of + byte values (0..255), or pairs, + where the length is drawn from (3..258) and the distance is + drawn from (1..32,768). In fact, the literal and length + alphabets are merged into a single alphabet (0..285), where + values 0..255 represent literal bytes, the value 256 indicates + end-of-block, and values 257..285 represent length codes + (possibly in conjunction with extra bits following the symbol + code) as follows: + + Extra Extra Extra + Code Bits Length(s) Code Bits Lengths Code Bits Length(s) + ---- ---- ------ ---- ---- ------- ---- ---- ------- + 257 0 3 267 1 15,16 277 4 67-82 + 258 0 4 268 1 17,18 278 4 83-98 + 259 0 5 269 2 19-22 279 4 99-114 + 260 0 6 270 2 23-26 280 4 115-130 + 261 0 7 271 2 27-30 281 5 131-162 + 262 0 8 272 2 31-34 282 5 163-194 + 263 0 9 273 3 35-42 283 5 195-226 + 264 0 10 274 3 43-50 284 5 227-257 + 265 1 11,12 275 3 51-58 285 0 258 + 266 1 13,14 276 3 59-66 + + The extra bits should be interpreted as a machine integer + stored with the most-significant bit first, e.g., bits 1110 + + + + + + + + + + + +Deutsch [Page 10] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + represent the value 14. + + Extra Extra Extra + Code Bits Dist Code Bits Dist Code Bits Distance + ---- ---- ---- ---- ---- ------ ---- ---- -------- + 0 0 1 10 4 33-48 20 9 1025-1536 + 1 0 2 11 4 49-64 21 9 1537-2048 + 2 0 3 12 5 65-96 22 10 2049-3072 + 3 0 4 13 5 97-128 23 10 3073-4096 + 4 1 5,6 14 6 129-192 24 11 4097-6144 + 5 1 7,8 15 6 193-256 25 11 6145-8192 + 6 2 9-12 16 7 257-384 26 12 8193-12288 + 7 2 13-16 17 7 385-512 27 12 12289-16384 + 8 3 17-24 18 8 513-768 28 13 16385-24576 + 9 3 25-32 19 8 769-1024 29 13 24577-32768 + + 3.2.6. Compression with fixed Huffman codes (BTYPE=01) + + The Huffman codes for the two alphabets are fixed, and are not + represented explicitly in the data. The Huffman code lengths + for the literal/length alphabet are: + + Lit Value Bits Codes + --------- ---- ----- + 0 - 143 8 00110000 through + 10111111 + 144 - 255 9 110010000 through + 111111111 + 256 - 279 7 0000000 through + 0010111 + 280 - 287 8 11000000 through + 11000111 + + The code lengths are sufficient to generate the actual codes, + as described above; we show the codes in the table for added + clarity. Literal/length values 286-287 will never actually + occur in the compressed data, but participate in the code + construction. + + Distance codes 0-31 are represented by (fixed-length) 5-bit + codes, with possible additional bits as shown in the table + shown in Paragraph 3.2.5, above. Note that distance codes + 30-31 will never actually occur in the compressed data. + + 3.2.7. Compression with dynamic Huffman codes (BTYPE=10) + + The Huffman codes for the two alphabets appear in the block + immediately after the header bits and before the actual + compressed data, first the literal/length code and then the + distance code. Each code is defined by a sequence of code + lengths, as discussed in Paragraph 3.2.2, above. For even + greater compactness, the code length sequences themselves are + + +Deutsch [Page 11] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + compressed using a Huffman code. The alphabet for code lengths + is as follows: + + 0 - 15: Represent code lengths of 0 - 15 + 16: Copy the previous code length 3 - 6 times. + The next 2 bits indicate repeat length + (0 = 3, ... , 3 = 6) + Example: Codes 8, 16 (+2 bits 11), + 16 (+2 bits 10) will expand to + 12 code lengths of 8 (1 + 6 + 5) + 17: Repeat a code length of 0 for 3 - 10 times. + (3 bits of length) + 18: Repeat a code length of 0 for 11 - 138 times + (7 bits of length) + + A code length of 0 indicates that the corresponding symbol in + the literal/length or distance alphabet will not occur in the + block, and should not participate in the Huffman code + construction algorithm given earlier. If only one distance + code is used, it is encoded using one bit, not zero bits; in + this case there is a single code length of one, with one unused + code. One distance code of zero bits means that there are no + distance codes used at all (the data is all literals). + + We can now define the format of the block: + + 5 Bits: HLIT, # of Literal/Length codes - 257 (257 - 286) + 5 Bits: HDIST, # of Distance codes - 1 (1 - 32) + 4 Bits: HCLEN, # of Code Length codes - 4 (4 - 19) + + (HCLEN + 4) x 3 bits: code lengths for the code length + alphabet given just above, in the order: 16, 17, 18, + 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15 + + These code lengths are interpreted as 3-bit integers + (0-7); as above, a code length of 0 means the + corresponding symbol (literal/length or distance code + length) is not used. + + HLIT + 257 code lengths for the literal/length alphabet, + encoded using the code length Huffman code + + HDIST + 1 code lengths for the distance alphabet, + encoded using the code length Huffman code + + The actual compressed data of the block, + encoded using the literal/length and distance Huffman + codes + + The literal/length symbol 256 (end of data), + encoded using the literal/length Huffman code + + + +Deutsch [Page 12] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + The code length repeat codes can cross from HLIT + 257 to the + HDIST + 1 code lengths. In other words, all code lengths form + a single sequence of HLIT + HDIST + 258 values. + + 3.3. Compliance + + A compressor may limit further the ranges of values specified in + the previous section and still be compliant; for example, it may + limit the range of backward pointers to some value smaller than + 32K. Similarly, a compressor may limit the size of blocks so that + a compressible block fits in memory. + + A compliant decompressor must accept the full range of possible + values defined in the previous section, and must accept blocks of + arbitrary size. + +4. Compression algorithm details + + While it is the intent of this document to define the 'deflate' + compressed data format without reference to any particular + compression algorithm, the format is related to the compressed + formats produced by LZ77 (Lempel-Ziv 1977, see reference [LZ77] + below); since many variations of LZ77 are patented, it is strongly + recommended that the implementor of a compressor follow the general + algorithm presented here, which is known not to be patented per se. + The material in this section is not part of the definition of the + specification per se, and a compressor need not follow it in order to + be compliant. + + The compressor terminates a block when it determines that starting a + new block with fresh trees would be useful, or when the block size + fills up the compressor's block buffer. + + The compressor uses a chained hash table to find duplicated strings, + using a hash function that operates on 3-byte sequences. At any + given point during compression, let XYZ be the next 3 input bytes to + be examined (not necessarily all different, of course). First, the + compressor examines the hash chain for XYZ. If the chain is empty, + the compressor simply writes out X as a literal byte and advances one + byte in the input. If the hash chain is not empty, indicating that + the sequence XYZ (or, if we are unlucky, some other 3 bytes with the + same hash function value) has occurred recently, the compressor + compares all strings on the XYZ hash chain with the actual input data + sequence starting at the current point, and selects the longest + match. + + The compressor searches the hash chains starting with the most recent + strings, to favor small distances and thus take advantage of the + Huffman encoding. The hash chains are singly linked. There are no + deletions from the hash chains; the algorithm simply discards matches + that are too old. To avoid a worst-case situation, very long hash + chains are arbitrarily truncated at a certain length, determined by a + + +Deutsch [Page 13] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + run-time parameter. + + To improve overall compression, the compressor optionally defers the + selection of matches ("lazy matching"): after a match of length N has + been found, the compressor searches for a longer match starting at + the next input byte. If it finds a longer match, it truncates the + previous match to a length of one (thus producing a single literal + byte) and then emits the longer match. Otherwise, it emits the + original match, and, as described above, advances N bytes before + continuing. + + Run-time parameters also control this "lazy match" procedure. If + compression ratio is most important, the compressor attempts a + complete second search regardless of the length of the first match. + In the normal case, if the current match is "long enough", the + compressor reduces the search for a longer match, thus speeding up + the process. If speed is most important, the compressor inserts new + strings in the hash table only when no match was found, or when the + match is not "too long". This degrades the compression ratio but + saves time since there are both fewer insertions and fewer searches. + +5. References + + [GZIP] Gailly, J.-L., and Adler, M., gzip documentation and sources, + available in prep.ai.mit.edu:/pub/gnu/gzip-*.tar + + [ZLIB] Gailly, J.-L., and Adler, M., zlib documentation and sources, + available in ftp.uu.net:/pub/archiving/zip/doc/zlib* + + [LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data + Compression", IEEE Transactions on Information Theory", Vol. 23, No. + 3, pp. 337-343. + + [HUFFMAN] Huffman, D. A., 'A Method for the Construction of Minimum + Redundancy Codes', Proceedings of the Institute of Radio Engineers, + September 1952, Volume 40, Number 9, pp. 1098-1101. + + [SCHWARTZ] Schwartz, E. S., and Kallick, B. "Generating a canonical + prefix encoding." Comm. ACM, 7,3 (Mar. 1964), pp. 166-169. + + [HIRSCHBERG] "Efficient decoding of prefix codes", Hirschberg and + Lelewer, Comm. ACM, 33,4, April 1990, pp. 449-459. + +6. Security considerations + + Any data compression method involves the reduction of redundancy in + the data. Consequently, any corruption of the data is likely to have + severe effects and be difficult to correct. Uncompressed text, on + the other hand, will probably still be readable despite the presence + of some corrupted bytes. + + It is recommended that systems using this data format provide some + + +Deutsch [Page 14] + +Internet DraftDEFLATE Compressed Data Format Specification 24 Jan 1996 + + + means of validating the integrity of the compressed data. See + reference [ZLIB], for example. + +7. Source code + + Source code for a C language implementation of a 'deflate' compliant + compressor and decompressor is available within the zlib package at + ftp.uu.net:/pub/archiving/zip/zlib/zlib*. + +8. Acknowledgements + + Trademarks cited in this document are the property of their + respective owners. + + Phil Katz designed the deflate format. Jean-Loup Gailly and Mark + Adler wrote the related software described in this specification. + Glenn Randers-Pehrson converted this document to Internet Draft and + HTML format. + +9. Author's address + + L. Peter Deutsch + + Aladdin Enterprises + 203 Santa Margarita Ave. + Menlo Park, CA 94025 + + Phone: (415) 322-0103 (AM only) + FAX: (415) 322-1734 + EMail: + + Questions about the technical content of this specification can be + sent by email to + + Jean-loup Gailly and + Mark Adler + + Editorial comments on this specification can be sent by email to + + L. Peter Deutsch and + Glenn Randers-Pehrson + + + + + + + + + + + + + +Deutsch [Page 15] diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\doc\gzip-4.3.doc corman\zlib\doc\gzip-4.3.doc --- corman3\zlib\doc\gzip-4.3.doc Wed Dec 31 16:00:00 1969 +++ corman\zlib\doc\gzip-4.3.doc Mon Jul 31 07:33:08 2006 @@ -0,0 +1,707 @@ + + + + + + +INTERNET-DRAFT L. Peter Deutsch +GZIP 4.3 Alladin Enterprises +Expires: 24 July 1996 24 Jan 1996 + +GZIP file format specification version 4.3 + +File draft-deutsch-gzip-4.3-00.txt + +Status of this Memo + + This document is an Internet-Draft. Internet-Drafts are working + documents of the Internet Engineering Task Force (IETF), its areas, + and its working groups. Note that other groups may also distribute + working documents as Internet-Drafts. + + Internet-Drafts are draft documents valid for a maximum of six months + and may be updated, replaced, or obsoleted by other documents at any + time. It is inappropriate to use Internet- Drafts as reference + material or to cite them other than as ``work in progress.'' + + To learn the current status of any Internet-Draft, please check the + ``1id-abstracts.txt'' listing contained in the Internet- Drafts + Shadow Directories on ftp.is.co.za (Africa), nic.nordu.net (Europe), + munnari.oz.au (Pacific Rim), ds.internic.net (US East Coast), or + ftp.isi.edu (US West Coast). + + Distribution of this memo is unlimited. + +Notices + + Copyright (C) 1995 L. Peter Deutsch + + Permission is granted to copy and distribute this document for any + purpose and without charge, including translations into other + languages and incorporation into compilations, provided that it is + copied as a whole (including the copyright notice and this notice) + and with no changes. + + Questions about this specification can be sent by email to Jean-loup + Gailly . + +Abstract + + This specification defines a lossless compressed data format that is + compatible with the widely used GZIP utility. The format includes a + cyclic redundancy check value for detecting data corruption. The + format presently uses the DEFLATE method of compression but can be + easily extended to use other compression methods. The format can be + + + +Deutsch [Page 1] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + implemented readily in a manner not covered by patents. + +Table of contents + + 1. Introduction ................................................... 2 + 1.1 Purpose .................................................... 2 + 1.2 Intended audience .......................................... 3 + 1.3 Scope ...................................................... 3 + 1.4 Compliance ................................................. 3 + 1.5 Definitions of terms and conventions used .................. 3 + 1.6 Changes from previous versions ............................. 3 + 2. Detailed specification ......................................... 4 + 2.1 Overall conventions ........................................ 4 + 2.2 File format ................................................ 5 + 2.3 Member format .............................................. 5 + 2.3.1. Member header and trailer ........................... 6 + 2.3.1.1. Extra field ....................................... 8 + 2.3.1.2. Compliance ........................................ 9 + 3. References ..................................................... 9 + 3.1 Related standards .......................................... 9 + 3.2 Other related publications ................................. 9 + 4. Security considerations ....................................... 10 + 5. Acknowledgements .............................................. 10 + 6. Author's address .............................................. 10 + 7. Appendix: Jean-loup Gailly's gzip utility ..................... 11 + 8. Appendix: Sample CRC Code ..................................... 11 + +1. Introduction + + 1.1. Purpose + + The purpose of this specification is to define a lossless + compressed data format that: + + o Is independent of CPU type, operating system, file system, + and character set, and hence can be used for interchange; + o Can compress or decompress a data stream (as opposed to a + randomly accessible file) to produce another data stream, + using only an a priori bounded amount of intermediate + storage, and hence can be used in data communications or + similar structures such as Unix filters; + o Compresses data with efficiency comparable to the best + currently available general-purpose compression methods, and + in particular considerably better than the 'compress' + program; + o Can be implemented readily in a manner not covered by + patents, and hence can be practiced freely; + o Is compatible with the file format produced by the current + widely used gzip utility, in that conforming decompressors + will be able to read data produced by the existing gzip + compressor. + + + +Deutsch [Page 2] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + The data format defined by this specification does not attempt to: + + o Provide random access to compressed data; + o Compress specialized data (e.g., raster graphics) as well as + the best currently available specialized algorithms. + + 1.2. Intended audience + + This specification is intended for use by implementors of software + to compress data into gzip format and/or decompress data from gzip + format. + + The text of the specification assumes a basic background in + programming at the level of bits and other primitive data + representations. + + 1.3. Scope + + The specification specifies a compression method and a file format + (the latter assuming only that a file can store a sequence of + arbitrary bytes). It does not specify any particular interface to + a file system or anything about character sets or encodings + (except for file names and comments, which are optional). + + 1.4. Compliance + + Unless otherwise indicated below, a compliant decompressor must be + able to accept and decompress any file that conforms to all the + specifications presented here; a compliant compressor must produce + files that conform to all the specifications presented here. The + material in the appendices is not part of the specification per se + and is not relevant to compliance. + + 1.5. Definitions of terms and conventions used + + byte: 8 bits stored or transmitted as a unit (same as an octet). + (For this specification, a byte is exactly 8 bits, even on + machines which store a character on a number of bits different + from 8.) See Section 2.1, below for the numbering of bits within + a byte. + + 1.6. Changes from previous versions + + There have been no technical changes to the gzip format since + version 4.1 of this specification. In version 4.2, some + terminology was changed, and the sample CRC code was rewritten for + clarity and to eliminate the requirement for the caller to do pre- + and post-conditioning. Version 4.3 is a conversion of the + specification to Internet Draft style. + +2. Detailed specification + + + +Deutsch [Page 3] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + 2.1. Overall conventions + + In the diagrams below, a box like this: + + +---+ + | | <-- the vertical bars might be missing + +---+ + + represents one byte; a box like this: + + +==============+ + | | + +==============+ + + represents a variable number of bytes. + + Bytes stored within a computer do not have a 'bit order', since + they are always treated as a unit. However, a byte considered as + an integer between 0 and 255 does have a most- and least- + significant bit, and since we write numbers with the most- + significant digit on the left, we also write bytes with the most- + significant bit on the left. In the diagrams below, we number the + bits of a byte so that bit 0 is the least-significant bit, i.e., + the bits are numbered: + + +--------+ + |76543210| + +--------+ + + This document does not address the issue of the order in which + bits of a byte are transmitted on a bit-sequential medium, since + the data format described here is byte- rather than bit-oriented. + + Within a computer, a number may occupy multiple bytes. All + multi-byte numbers in the format described here are stored with + the least-significant byte first (at the lower memory address). + For example, the decimal number 520 is stored as: + + 0 1 + +--------+--------+ + |00001000|00000010| + +--------+--------+ + ^ ^ + | | + | + more significant byte = 2 x 256 + + less significant byte = 8 + + 2.2. File format + + A gzip file consists of a series of "members" (compressed data + sets). The format of each member is specified in the following + section. The members simply appear one after another in the file, + + +Deutsch [Page 4] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + with no additional information before, between, or after them. + + 2.3. Member format + + Each member has the following structure: + + +---+---+---+---+---+---+---+---+---+---+ + |ID1|ID2|CM |FLG| MTIME |XFL|OS | (more-->) + +---+---+---+---+---+---+---+---+---+---+ + + (if FLG.FEXTRA set) + + +---+---+=================================+ + | XLEN |...XLEN bytes of 'extra field'...| (more-->) + +---+---+=================================+ + + (if FLG.FNAME set) + + +=========================================+ + |...original file name, zero-terminated...| (more-->) + +=========================================+ + + (if FLG.FCOMMENT set) + + +===================================+ + |...file comment, zero-terminated...| (more-->) + +===================================+ + + (if FLG.FHCRC set) + + +---+---+ + | CRC16 | + +---+---+ + + +=======================+ + |...compressed blocks...| (more-->) + +=======================+ + + 0 1 2 3 4 5 6 7 + +---+---+---+---+---+---+---+---+ + | CRC32 | ISIZE | + +---+---+---+---+---+---+---+---+ + + 2.3.1. Member header and trailer + + ID1 (IDentification 1) + + ID2 (IDentification 2) + + These have the fixed values ID1 = 31 (0x1f, \037), ID2 = 139 + (0x8b, \213), to identify the file as being in gzip format. + + + +Deutsch [Page 5] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + CM (Compression Method) + + This identifies the compression method used in the file. CM + = 0-7 are reserved. CM = 8 denotes the 'deflate' + compression method, which is the one customarily used by + gzip and which is documented elsewhere. + + FLG (FLaGs) + + This flag byte is divided into individual bits as follows: + + bit 0 FTEXT + bit 1 FHCRC + bit 2 FEXTRA + bit 3 FNAME + bit 4 FCOMMENT + bit 5 reserved + bit 6 reserved + bit 7 reserved + + If FTEXT is set, the file is probably ASCII text. This is + an optional indication, which the compressor may set by + checking a small amount of the input data to see whether any + non-ASCII characters are present. In case of doubt, FTEXT + is cleared, indicating binary data. For systems which have + different file formats for ascii text and binary data, the + decompressor can use FTEXT to choose the appropriate format. + We deliberately do not specify the algorithm used to set + this bit, since a compressor always has the option of + leaving it cleared and a decompressor always has the option + of ignoring it and letting some other program handle issues + of data conversion. + + If FHCRC is set, a CRC16 for the gzip header is present, + immediately before the compressed data. The CRC16 consists + of the two least significant bytes of the CRC32 for all + bytes of the gzip header up to and not including the CRC16. + [The FHCRC bit was never set by versions of gzip up to + 1.2.4, even though it was documented with a different + meaning in gzip 1.2.4.] + + If FEXTRA is set, optional extra fields are present, as + described in a following section. + + If FNAME is set, an original file name is present, + terminated by a zero byte. The name must consist of ISO + 8859-1 (LATIN-1) characters; on operating systems using + EBCDIC or any other character set for file names, the name + must be translated to the ISO LATIN-1 character set. This + is the original name of the file being compressed, with any + directory components removed, and, if the file being + compressed is on a file system with case insensitive names, + + +Deutsch [Page 6] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + forced to lower case. There is no original file name if the + data was compressed from a source other than a named file; + for example, if the source was stdin on a Unix system, there + is no file name. + + If FCOMMENT is set, a zero-terminated file comment is + present. This comment is not interpreted; it is only + intended for human consumption. The comment must consist of + ISO 8859-1 (LATIN-1) characters. Line breaks should be + denoted by a single line feed character (10 decimal). + + Reserved FLG bits must be zero. + + MTIME (Modification TIME) + + This gives the most recent modification time of the original + file being compressed. The time is in Unix format, i.e., + seconds since 00:00:00 GMT, Jan. 1, 1970. (Note that this + may cause problems for MS-DOS and other systems that use + local rather than Universal time.) If the compressed data + did not come from a file, MTIME is set to the time at which + compression started. MTIME = 0 means no time stamp is + available. + + XFL (eXtra FLags) + + These flags are available for use by specific compression + methods. The 'deflate' method (CM = 8) sets these flags as + follows: + + XFL = 2 - compressor used maximum compression, + slowest algorithm + XFL = 4 - compressor used fastest algorithm + + OS (Operating System) + + This identifies the type of file system on which compression + took place. This may be useful in determining end-of-line + convention for text files. The currently defined values are + as follows: + + + + + + + + + + + + + + +Deutsch [Page 7] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + 0 - FAT filesystem (MS-DOS, OS/2, NT/Win32) + 1 - Amiga + 2 - VMS (or OpenVMS) + 3 - Unix + 4 - VM/CMS + 5 - Atari TOS + 6 - HPFS filesystem (OS/2, NT) + 7 - Macintosh + 8 - Z-System + 9 - CP/M + 10 - TOPS-20 + 11 - NTFS filesystem (NT) + 12 - QDOS + 13 - Acorn RISCOS + 255 - unknown + + XLEN (eXtra LENgth) + + If FLG.FEXTRA is set, this gives the length of the optional + extra field. See below for details. + + CRC32 (CRC-32) + + This contains a Cyclic Redundancy Check value of the + uncompressed data computed according to CRC-32 algorithm + used in the ISO 3309 standard and in section 8.1.1.6.2 of + ITU-T recommendation V.42. (See http://www.iso.ch for + ordering ISO documents. See gopher://info.itu.ch for an + online version of ITU-T V.42.) + + ISIZE (Input SIZE) + + This contains the size of the original (uncompressed) input + data modulo 2^32. + + 2.3.1.1. Extra field + + If the FLG.FEXTRA bit is set, an "extra field" is present in + the header, with total length XLEN bytes. It consists of a + series of subfields, each of the form: + + +---+---+---+---+==================================+ + |SI1|SI2| LEN |... LEN bytes of subfield data ...| + +---+---+---+---+==================================+ + + SI1 and SI2 provide a subfield ID, typically two ASCII letters + with some mnemonic value. Jean-loup Gailly + is maintaining a registry of subfield + IDs; please send him any subfield ID you wish to use. Subfield + IDs with SI2 = 0 are reserved for future use. The following + IDs are currently defined: + + + +Deutsch [Page 8] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + SI1 SI2 Data + ---------- ---------- ---- + 0x41 ('A') 0x70 ('P') Apollo file type information + + LEN gives the length of the subfield data, excluding the 4 + initial bytes. + + 2.3.1.2. Compliance + + A compliant compressor must produce files with correct ID1, + ID2, CM, CRC32, and ISIZE, but may set all the other fields in + the fixed-length part of the header to default values (255 for + OS, 0 for all others). The compressor must set all reserved + bits to zero. + + A compliant decompressor must check ID1, ID2, and CM, and + provide an error indication if any of these have incorrect + values. It must examine FEXTRA/XLEN, FNAME, FCOMMENT and FHCRC + at least so it can skip over the optional fields if they are + present. It need not examine any other part of the header or + trailer; in particular, a decompressor may ignore FTEXT and OS + and always produce binary output, and still be compliant. A + compliant decompressor must give an error indication if any + reserved bit is non-zero, since such a bit could indicate the + presence of a new field that would cause subsequent data to be + interpreted incorrectly. + +3. References + + 3.1. Related standards + + "Information Processing - 8-bit single-byte coded graphic + character sets - Part 1: Latin alphabet No.1" (ISO 8859-1:1987). + The ISO 8859-1 (Latin-1) character set is a superset of 7-bit + ASCII. Files defining this character set may be obtained from + ftp.uu.net:/graphics/png/documents/iso_8859-1.* + + ISO 3309 + + ITU-T recommendation V.42 + + 3.2. Other related publications + + Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + available in ftp.uu.net:/pub/archiving/zip/doc/deflate-*.doc + + Gailly, J.-L., gzip documentation, available in + prep.ai.mit.edu:/pub/gnu/gzip-*.tar + + [Sarwate88] Sarwate, D.V., "Computation of Cyclic Redundancy + Checks via Table Look-Up", Communications of the ACM, 31(8), + pp.1008-1013. + + +Deutsch [Page 9] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + Schwaderer, W.D., "CRC Calculation", April 85 PC Tech Journal, + pp.118-133. + + ftp.adelaide.edu.au:/pub/rocksoft/papers/crc_v3.txt, describing + the CRC concept. + +4. Security considerations + + Any data compression method involves the reduction of redundancy in + the data. Consequently, any corruption of the data is likely to have + severe effects and be difficult to correct. Uncompressed text, on + the other hand, will probably still be readable despite the presence + of some corrupted bytes. + + It is recommended that systems using this data format provide some + means of validating the integrity of the compressed data, such as by + setting and checking the CRC-32 check value. + +5. Acknowledgements + + Trademarks cited in this document are the property of their + respective owners. + + Jean-Loup Gailly designed the gzip format and wrote, with Mark Adler, + the related software described in this specification. Glenn + Randers-Pehrson converted this document to Internet Draft and HTML + format. + +6. Author's address + + L. Peter Deutsch + + Aladdin Enterprises + 203 Santa Margarita Ave. + Menlo Park, CA 94025 + + Phone: (415) 322-0103 (AM only) + FAX: (415) 322-1734 + EMail: + + Questions about the technical content of this specification can be + sent by email to + + Jean-loup Gailly and + Mark Adler + + Editorial comments on this specification can be sent by email to + + L. Peter Deutsch and + Glenn Randers-Pehrson + +7. Appendix: Jean-loup Gailly's gzip utility + + +Deutsch [Page 10] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + The most widely used implementation of gzip compression, and the + original documentation on which this specification is based, were + created by Jean-loup Gailly . Since this + implementation is a de facto standard, we mention some more of its + features here. Again, the material in this section is not part of + the specification per se, and implementations need not follow it to + be compliant. + + When compressing or decompressing a file, gzip preserves the + protection, ownership, and modification time attributes on the local + file system, since there is no provision for representing protection + attributes in the gzip file format itself. Since the file format + includes a modification time, the gzip decompressor provides a + command line switch that assigns the modification time from the file, + rather than the local modification time of the compressed input, to + the decompressed output. + +8. Appendix: Sample CRC Code + + The following sample code represents a practical implementation of + the CRC (Cyclic Redundancy Check). (See also ISO 3309 and ITU-T V.42 + for a formal specification.) + + The sample code is in the ANSI C programming language. Non C users + may find it easier to read with these hints: + + & Bitwise AND operator. + ^ Bitwise exclusive-OR operator. + >> Bitwise right shift operator. When applied to an + unsigned quantity, as here, right shift inserts zero + bit(s) at the left. + ! Logical NOT operator. + ++ "n++" increments the variable n. + 0xNNN 0x introduces a hexadecimal (base 16) constant. + Suffix L indicates a long value (at least 32 bits). + + /* Table of CRCs of all 8-bit messages. */ + unsigned long crc_table[256]; + + /* Flag: has the table been computed? Initially false. */ + int crc_table_computed = 0; + + /* Make the table for a fast CRC. */ + void make_crc_table(void) + { + unsigned long c; + int n, k; + + + + + + + +Deutsch [Page 11] + +Internet Draft GZIP Compressed Data Format Specification 24 Jan 1996 + + + for (n = 0; n < 256; n++) { + c = (unsigned long) n; + for (k = 0; k < 8; k++) { + if (c & 1) { + c = 0xedb88320L ^ (c >> 1); + } else { + c = c >> 1; + } + } + crc_table[n] = c; + } + crc_table_computed = 1; + } + + /* + Update a running crc with the bytes buf[0..len-1] and return + the updated crc. The crc should be initialized to zero. Pre- and + post-conditioning (one's complement) is performed within this + function so it shouldn't be done by the caller. Usage example: + + unsigned long crc = 0L; + + while (read_buffer(buffer, length) != EOF) { + crc = update_crc(crc, buffer, length); + } + if (crc != original_crc) error(); + */ + unsigned long update_crc(unsigned long crc, + unsigned char *buf, int len) + { + unsigned long c = crc ^ 0xffffffffL; + int n; + + if (!crc_table_computed) + make_crc_table(); + for (n = 0; n < len; n++) { + c = crc_table[(c ^ buf[n]) & 0xff] ^ (c >> 8); + } + return c ^ 0xffffffffL; + } + + /* Return the CRC of the bytes buf[0..len-1]. */ + unsigned long crc(unsigned char *buf, int len) + { + return update_crc(0L, buf, len); + } + + + + + + + + +Deutsch [Page 12] diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\doc\zlib-3.3.doc corman\zlib\doc\zlib-3.3.doc --- corman3\zlib\doc\zlib-3.3.doc Wed Dec 31 16:00:00 1969 +++ corman\zlib\doc\zlib-3.3.doc Mon Jul 31 07:33:08 2006 @@ -0,0 +1,589 @@ + + + + + + +INTERNET-DRAFT L. Peter Deutsch +ZLIB 3.3 Aladdin Enterprises +Expires: 30 July 1996 Jean-Loup Gailly + Info-Zip + 30 Jan 1996 + +ZLIB Compressed Data Format Specification version 3.3 + +File draft-deutsch-zlib-3.3-00.txt + +Status of this Memo + + This document is an Internet-Draft. Internet-Drafts are working + documents of the Internet Engineering Task Force (IETF), its areas, + and its working groups. Note that other groups may also distribute + working documents as Internet-Drafts. + + Internet-Drafts are draft documents valid for a maximum of six months + and may be updated, replaced, or obsoleted by other documents at any + time. It is inappropriate to use Internet- Drafts as reference + material or to cite them other than as ``work in progress.'' + + To learn the current status of any Internet-Draft, please check the + ``1id-abstracts.txt'' listing contained in the Internet- Drafts + Shadow Directories on ftp.is.co.za (Africa), nic.nordu.net (Europe), + munnari.oz.au (Pacific Rim), ds.internic.net (US East Coast), or + ftp.isi.edu (US West Coast). + + Distribution of this memo is unlimited. + + Notices + + Copyright (C) 1995 L. Peter Deutsch and Jean-loup Gailly + + Permission is granted to copy and distribute this document for any + purpose and without charge, including translations into other + languages and incorporation into compilations, provided that it is + copied as a whole (including the copyright notice and this notice) + and with no changes. + +Abstract + + This specification defines a lossless compressed data format. The + data can be produced or consumed, even for an arbitrarily long + sequentially presented input data stream, using only an a priori + bounded amount of intermediate storage. The format presently uses + the DEFLATE compression method but can be easily extended to use + other compression methods. It can be implemented readily in a manner + + + +Deutsch and Gailly [Page 1] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + not covered by patents. This specification also defines the ADLER-32 + checksum (an extension and improvement of the Fletcher checksum), + used for detection of data corruption, and provides an algorithm for + computing it. + +Table of contents + + 1. Introduction ................................................... 2 + 1.1 Purpose .................................................... 2 + 1.2 Intended audience .......................................... 3 + 1.3 Scope ...................................................... 3 + 1.4 Compliance ................................................. 3 + 1.5 Definitions of terms and conventions used ................. 3 + 1.6 Changes from previous versions ............................. 3 + 2. Detailed specification ......................................... 3 + 2.1 Overall conventions ........................................ 3 + 2.2 Data format ................................................ 4 + 2.3 Compliance ................................................. 6 + 3. References ..................................................... 7 + 4. Source code .................................................... 7 + 5. Security considerations ........................................ 7 + 6. Acknowledgements ............................................... 7 + 7. Authors' addresses ............................................. 7 + 8. Appendix: Rationale ............................................ 8 + 9. Appendix: Sample code .......................................... 9 + +1. Introduction + + 1.1. Purpose + + The purpose of this specification is to define a lossless + compressed data format that: + + o Is independent of CPU type, operating system, file system, + and character set, and hence can be used for interchange; + + o Can be produced or consumed, even for an arbitrarily long + sequentially presented input data stream, using only an a + priori bounded amount of intermediate storage, and hence can + be used in data communications or similar structures such as + Unix filters; + + o Can use a number of different compression methods; + + o Can be implemented readily in a manner not covered by + patents, and hence can be practiced freely. + + The data format defined by this specification does not attempt to + allow random access to compressed data. + 1.2. Intended audience + + This specification is intended for use by implementors of software + + +Deutsch and Gailly [Page 2] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + to compress data into zlib format and/or decompress data from zlib + format. + + The text of the specification assumes a basic background in + programming at the level of bits and other primitive data + representations. + + 1.3. Scope + + The specification specifies a compressed data format that can be + used for in-memory compression of a sequence of arbitrary bytes. + + 1.4. Compliance + + Unless otherwise indicated below, a compliant decompressor must be + able to accept and decompress any data set that conforms to all + the specifications presented here; a compliant compressor must + produce data sets that conform to all the specifications presented + here. + + 1.5. Definitions of terms and conventions used + + byte: 8 bits stored or transmitted as a unit (same as an octet). + (For this specification, a byte is exactly 8 bits, even on + machines which store a character on a number of bits different + from 8.) See Section 2.1, below, for the numbering of bits within + a byte. + + 1.6. Changes from previous versions + + Version 3.1 was the first public release of this specification. + In version 3.2, some terminology was changed and the Adler-32 + sample code was rewritten for clarity. In version 3.3, the + support for a preset dictionary was introduced, and the + specification was converted to Internet Draft style. + +2. Detailed specification + + 2.1. Overall conventions + + In the diagrams below, a box like this: + + +---+ + | | <-- the vertical bars might be missing + +---+ + + represents one byte; a box like this: + + +==============+ + | | + +==============+ + + + +Deutsch and Gailly [Page 3] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + represents a variable number of bytes. + + Bytes stored within a computer do not have a 'bit order', since + they are always treated as a unit. However, a byte considered as + an integer between 0 and 255 does have a most- and least- + significant bit, and since we write numbers with the most- + significant digit on the left, we also write bytes with the most- + significant bit on the left. In the diagrams below, we number the + bits of a byte so that bit 0 is the least-significant bit, i.e., + the bits are numbered: + + +--------+ + |76543210| + +--------+ + + Within a computer, a number may occupy multiple bytes. All + multi-byte numbers in the format described here are stored with + the MOST-significant byte first (at the lower memory address). + For example, the decimal number 520 is stored as: + + 0 1 + +--------+--------+ + |00000010|00001000| + +--------+--------+ + ^ ^ + | | + | + less significant byte = 8 + + more significant byte = 2 x 256 + + 2.2. Data format + + A zlib stream has the following structure: + + 0 1 + +---+---+ + |CMF|FLG| (more-->) + +---+---+ + + (if FLG.FDICT set) + + 0 1 2 3 + +---+---+---+---+ + | DICTID | (more-->) + +---+---+---+---+ + + +=====================+---+---+---+---+ + |...compressed data...| ADLER32 | + +=====================+---+---+---+---+ + + Any data which may appear after ADLER32 are not part of the zlib + stream. + + + +Deutsch and Gailly [Page 4] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + CMF (Compression Method and flags) + + This byte is divided into a 4-bit compression method and a 4- + bit information field depending on the compression method. + + bits 0 to 3 CM Compression method + bits 4 to 7 CINFO Compression info + + CM (Compression method) + + This identifies the compression method used in the file. CM = 8 + denotes the 'deflate' compression method with a window size up + to 32K. This is the method used by gzip and PNG (see + references [GZIP] and [PNG] in Chapter 3, below, for the + reference documents). CM = 15 is reserved. It might be used + in a future version of this specification to indicate the + presence of an extra field before the compressed data. + + CINFO (Compression info) + + For CM = 8, CINFO is the base-2 logarithm of the LZ77 window + size, minus eight (CINFO=7 indicates a 32K window size). Values + of CINFO above 7 are not allowed in this version of the + specification. CINFO is not defined in this specification for + CM not equal to 8. + + FLG (FLaGs) + + This flag byte is divided as follows: + + bits 0 to 4 FCHECK (check bits for CMF and FLG) + bit 5 FDICT (preset dictionary) + bits 6 to 7 FLEVEL (compression level) + + The FCHECK value must be such that CMF and FLG, when viewed as + a 16-bit unsigned integer stored in MSB order (CMF*256 + FLG), + is a multiple of 31. + + FDICT (Preset dictionary) + + If FDICT is set, a DICT dictionary identifier is present + immediately after the FLG byte. The dictionary is a sequence of + bytes which are initially fed to the compressor without + producing any compressed output. DICT is the Adler-32 checksum + of this sequence of bytes (see the definition of ADLER32 + below). The decompressor can use this identifier to determine + which dictionary has been used by the compressor. + + FLEVEL (Compression level) + + These flags are available for use by specific compression + methods. The 'deflate' method (CM = 8) sets these flags as + + +Deutsch and Gailly [Page 5] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + follows: + + 0 - compressor used fastest algorithm + 1 - compressor used fast algorithm + 2 - compressor used default algorithm + 3 - compressor used maximum compression, slowest algorithm + + The information in FLEVEL is not needed for decompression; it + is there to indicate if recompression might be worthwhile. + + compressed data + + For compression method 8, the compressed data is stored in the + deflate compressed data format as described in the document + "'Deflate' Compressed Data Format Specification" by L. Peter + Deutsch. (See reference [DEFLATE] in Chapter 3, below) + + Other compressed data formats are not specified in this version + of the zlib specification. + + ADLER32 (Adler-32 checksum) + + This contains a checksum value of the uncompressed data + (excluding any dictionary data) computed according to Adler-32 + algorithm. This algorithm is a 32-bit extension and improvement + of the Fletcher algorithm, used in the ITU-T X.224 / ISO 8073 + standard. See references [FLETCHER] and [ITU-T] in Chapter 3, + below) + + Adler-32 is composed of two sums accumulated per byte: s1 is + the sum of all bytes, s2 is the sum of all s1 values. Both sums + are done modulo 65521. s1 is initialized to 1, s2 to zero. The + Adler-32 checksum is stored as s2*65536 + s1 in most- + significant-byte first (network) order. + + 2.3. Compliance + + A compliant compressor must produce streams with correct CMF, FLG + and ADLER32, but need not support preset dictionaries. When the + zlib data format is used as part of another standard data format, + the compressor may use only preset dictionaries that are specified + by this other data format. If this other format does not use the + preset dictionary feature, the compressor must not set the FDICT + flag. + + A compliant decompressor must check CMF, FLG, and ADLER32, and + provide an error indication if any of these have incorrect values. + A compliant decompressor must give an error indication if CM is + not one of the values defined in this specification (only the + value 8 is permitted in this version), since another value could + indicate the presence of new features that would cause subsequent + data to be interpreted incorrectly. A compliant decompressor must + + +Deutsch and Gailly [Page 6] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + give an error indication if FDICT is set and DICTID is not the + identifier of a known preset dictionary. A decompressor may + ignore FLEVEL and still be compliant. When the zlib data format + is being used as a part of another standard format, a compliant + decompressor must support all the preset dictionaries specified by + the other format. When the other format does not use the preset + dictionary feature, a compliant decompressor must reject any + stream in which the FDICT flag is set. + +3. References + + [GZIP] Deutsch, L.P.,"'Gzip' Compressed Data Format Specification". + available in ftp.uu.net:/pub/archiving/zip/doc/gzip-*.doc + + [DEFLATE] Deutsch, L.P.,"'Deflate' Compressed Data Format + Specification". available in + ftp.uu.net:/pub/archiving/zip/doc/deflate-*.doc + + [PNG] Thomas Boutell, "PNG (Portable Network Graphics) + specification". available in ftp://ftp.uu.net/graphics/png/png* + + [FLETCHER] Fletcher, J. G., "An Arithmetic Checksum for Serial + Transmissions," IEEE Transactions on Communications, Vol. COM-30, No. + 1, January 1982, pp. 247-252. + + [ITU-T] ITU-T Recommendation X.224, Annex D, "Checksum Algorithms," + November, 1993, pp. 144, 145. (Available from gopher://info.itu.ch). + ITU-T X.244 is also the same as ISO 8073. + +4. Source code + + Source code for a C language implementation of a 'zlib' compliant + library is available at ftp.uu.net:/pub/archiving/zip/zlib/zlib*. + +5. Security considerations + + A decoder that fails to check the ADLER32 checksum value may be + subject to undetected data corruption. + +6. Acknowledgements + + Trademarks cited in this document are the property of their + respective owners. + + Jean-Loup Gailly and Mark Adler designed the zlib format and wrote + the related software described in this specification. Glenn + Randers-Pehrson converted this document to Internet Draft and HTML + format. + +7. Authors' addresses L. Peter Deutsch + + Aladdin Enterprises + + +Deutsch and Gailly [Page 7] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + 203 Santa Margarita Ave. + Menlo Park, CA 94025 + + Phone: (415) 322-0103 (AM only) + FAX: (415) 322-1734 + EMail: + + Jean-loup Gailly + EMail: + + Questions about the technical content of this specification can be + sent by email to + + Jean-loup Gailly and + Mark Adler + + Editorial comments on this specification can be sent by email to + + L. Peter Deutsch and + Glenn Randers-Pehrson + +8. Appendix: Rationale + + 8.1. Preset dictionaries + + A preset dictionary is specially useful to compress short input + sequences. The compressor can take advantage of the dictionary + context to encode the input in a more compact manner. The + decompressor can be initialized with the appropriate context by + virtually decompressing a compressed version of the dictionary + without producing any output. However for certain compression + algorithms such as the deflate algorithm this operation be + optimized without actually performing any decompression. + + The compressor and the decompressor must use exactly the same + dictionary. The dictionary may be fixed or may be chosen among a + certain number of predefined dictionaries, according to the kind + of input data. The decompressor can determine which dictionary has + been chosen by the compressor by checking the dictionary + identifier. This document does not specify the contents of + predefined dictionaries, since the optimal dictionaries are + application specific. Standard data formats using this feature of + the zlib specification must precisely define the allowed + dictionaries. + + 8.2. The Adler-32 algorithm + + The Adler-32 algorithm is much faster than the CRC32 algorithm yet + still provides an extremely low probability of undetected errors. + + The modulo on unsigned long accumulators can be delayed for 5552 + bytes, so the modulo operation time is negligible. If the bytes + + +Deutsch and Gailly [Page 8] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + are a, b, c, the second sum is 3a + 2b + c + 3, and so is position + and order sensitive, unlike the first sum, which is just a + checksum. That 65521 is prime is important to avoid a possible + large class of two-byte errors that leave the check unchanged. + (The Fletcher checksum uses 255, which is not prime and which also + makes the Fletcher check insensitive to single byte changes 0 + 255.) + + The sum s1 is initialized to 1 instead of zero to make the length + of the sequence part of s2, so that the length does not have to be + checked separately. (Any sequence of zeroes has a Fletcher + checksum of zero.) + +9. Appendix: Sample code + + The following C code computes the Adler-32 checksum of a data buffer. + It is written for clarity, not for speed. The sample code is in the + ANSI C programming language. Non C users may find it easier to read + with these hints: + + & Bitwise AND operator. + >> Bitwise right shift operator. When applied to an + unsigned quantity, as here, right shift inserts zero bit(s) + at the left. + << Bitwise left shift operator. Left shift inserts zero + bit(s) at the right. + ++ "n++" increments the variable n. + % modulo operator: a % b is the remainder of a divided by b. + + #define BASE 65521 /* largest prime smaller than 65536 */ + + /* + Update a running Adler-32 checksum with the bytes buf[0..len-1] + and return the updated checksum. The Adler-32 checksum should be + initialized to 1. + + Usage example: + + unsigned long adler = 1L; + + while (read_buffer(buffer, length) != EOF) { + adler = update_adler32(adler, buffer, length); + } + if (adler != original_adler) error(); + */ + unsigned long update_adler32(unsigned long adler, + unsigned char *buf, int len) + { + unsigned long s1 = adler & 0xffff; + unsigned long s2 = (adler >> 16) & 0xffff; + int n; + + + +Deutsch and Gailly [Page 9] + +Internet Draft ZLIB Compressed Data Format Specification 30 Jan 1996 + + + for (n = 0; n < len; n++) { + s1 = (s1 + buf[n]) % BASE; + s2 = (s2 + s1) % BASE; + } + return (s2 << 16) + s1; + } + + /* Return the adler32 of the bytes buf[0..len-1] */ + + unsigned long adler32(unsigned char *buf, int len) + { + return update_adler32(1L, buf, len); + } + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Deutsch and Gailly [Page 10] diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\infblock.c corman\zlib\infblock.c --- corman3\zlib\infblock.c Wed Dec 31 16:00:00 1969 +++ corman\zlib\infblock.c Mon Jul 31 07:33:09 2006 @@ -0,0 +1,398 @@ +/* infblock.c -- interpret and process block types to last block + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +#include "zutil.h" +#include "infblock.h" +#include "inftrees.h" +#include "infcodes.h" +#include "infutil.h" + +struct inflate_codes_state {int dummy;}; /* for buggy compilers */ + +/* simplify the use of the inflate_huft type with some defines */ +#define exop word.what.Exop +#define bits word.what.Bits + +/* Table for deflate from PKZIP's appnote.txt. */ +local const uInt border[] = { /* Order of the bit length code lengths */ + 16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15}; + +/* + Notes beyond the 1.93a appnote.txt: + + 1. Distance pointers never point before the beginning of the output + stream. + 2. Distance pointers can point back across blocks, up to 32k away. + 3. There is an implied maximum of 7 bits for the bit length table and + 15 bits for the actual data. + 4. If only one code exists, then it is encoded using one bit. (Zero + would be more efficient, but perhaps a little confusing.) If two + codes exist, they are coded using one bit each (0 and 1). + 5. There is no way of sending zero distance codes--a dummy must be + sent if there are none. (History: a pre 2.0 version of PKZIP would + store blocks with no distance codes, but this was discovered to be + too harsh a criterion.) Valid only for 1.93a. 2.04c does allow + zero distance codes, which is sent as one code of zero bits in + length. + 6. There are up to 286 literal/length codes. Code 256 represents the + end-of-block. Note however that the static length tree defines + 288 codes just to fill out the Huffman codes. Codes 286 and 287 + cannot be used though, since there is no length base or extra bits + defined for them. Similarily, there are up to 30 distance codes. + However, static trees define 32 codes (all 5 bits) to fill out the + Huffman codes, but the last two had better not show up in the data. + 7. Unzip can check dynamic Huffman blocks for complete code sets. + The exception is that a single code would not be complete (see #4). + 8. The five bits following the block type is really the number of + literal codes sent minus 257. + 9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits + (1+6+6). Therefore, to output three times the length, you output + three codes (1+1+1), whereas to output four times the same length, + you only need two codes (1+3). Hmm. + 10. In the tree reconstruction algorithm, Code = Code + Increment + only if BitLength(i) is not zero. (Pretty obvious.) + 11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19) + 12. Note: length code 284 can represent 227-258, but length code 285 + really is 258. The last length deserves its own, short code + since it gets used a lot in very redundant files. The length + 258 is special since 258 - 3 (the min match length) is 255. + 13. The literal/length and distance code bit lengths are read as a + single stream of lengths. It is possible (and advantageous) for + a repeat code (16, 17, or 18) to go across the boundary between + the two sets of lengths. + */ + + +void inflate_blocks_reset(s, z, c) +inflate_blocks_statef *s; +z_streamp z; +uLongf *c; +{ + if (c != Z_NULL) + *c = s->check; + if (s->mode == BTREE || s->mode == DTREE) + ZFREE(z, s->sub.trees.blens); + if (s->mode == CODES) + inflate_codes_free(s->sub.decode.codes, z); + s->mode = TYPE; + s->bitk = 0; + s->bitb = 0; + s->read = s->write = s->window; + if (s->checkfn != Z_NULL) + z->adler = s->check = (*s->checkfn)(0L, (const Bytef *)Z_NULL, 0); + Tracev((stderr, "inflate: blocks reset\n")); +} + + +inflate_blocks_statef *inflate_blocks_new(z, c, w) +z_streamp z; +check_func c; +uInt w; +{ + inflate_blocks_statef *s; + + if ((s = (inflate_blocks_statef *)ZALLOC + (z,1,sizeof(struct inflate_blocks_state))) == Z_NULL) + return s; + if ((s->hufts = + (inflate_huft *)ZALLOC(z, sizeof(inflate_huft), MANY)) == Z_NULL) + { + ZFREE(z, s); + return Z_NULL; + } + if ((s->window = (Bytef *)ZALLOC(z, 1, w)) == Z_NULL) + { + ZFREE(z, s->hufts); + ZFREE(z, s); + return Z_NULL; + } + s->end = s->window + w; + s->checkfn = c; + s->mode = TYPE; + Tracev((stderr, "inflate: blocks allocated\n")); + inflate_blocks_reset(s, z, Z_NULL); + return s; +} + + +int inflate_blocks(s, z, r) +inflate_blocks_statef *s; +z_streamp z; +int r; +{ + uInt t; /* temporary storage */ + uLong b; /* bit buffer */ + uInt k; /* bits in bit buffer */ + Bytef *p; /* input data pointer */ + uInt n; /* bytes available there */ + Bytef *q; /* output window write pointer */ + uInt m; /* bytes to end of window or read pointer */ + + /* copy input/output information to locals (UPDATE macro restores) */ + LOAD + + /* process input based on current state */ + while (1) switch (s->mode) + { + case TYPE: + NEEDBITS(3) + t = (uInt)b & 7; + s->last = t & 1; + switch (t >> 1) + { + case 0: /* stored */ + Tracev((stderr, "inflate: stored block%s\n", + s->last ? " (last)" : "")); + DUMPBITS(3) + t = k & 7; /* go to byte boundary */ + DUMPBITS(t) + s->mode = LENS; /* get length of stored block */ + break; + case 1: /* fixed */ + Tracev((stderr, "inflate: fixed codes block%s\n", + s->last ? " (last)" : "")); + { + uInt bl, bd; + inflate_huft *tl, *td; + + inflate_trees_fixed(&bl, &bd, &tl, &td, z); + s->sub.decode.codes = inflate_codes_new(bl, bd, tl, td, z); + if (s->sub.decode.codes == Z_NULL) + { + r = Z_MEM_ERROR; + LEAVE + } + } + DUMPBITS(3) + s->mode = CODES; + break; + case 2: /* dynamic */ + Tracev((stderr, "inflate: dynamic codes block%s\n", + s->last ? " (last)" : "")); + DUMPBITS(3) + s->mode = TABLE; + break; + case 3: /* illegal */ + DUMPBITS(3) + s->mode = BAD; + z->msg = (char*)"invalid block type"; + r = Z_DATA_ERROR; + LEAVE + } + break; + case LENS: + NEEDBITS(32) + if ((((~b) >> 16) & 0xffff) != (b & 0xffff)) + { + s->mode = BAD; + z->msg = (char*)"invalid stored block lengths"; + r = Z_DATA_ERROR; + LEAVE + } + s->sub.left = (uInt)b & 0xffff; + b = k = 0; /* dump bits */ + Tracev((stderr, "inflate: stored length %u\n", s->sub.left)); + s->mode = s->sub.left ? STORED : (s->last ? DRY : TYPE); + break; + case STORED: + if (n == 0) + LEAVE + NEEDOUT + t = s->sub.left; + if (t > n) t = n; + if (t > m) t = m; + zmemcpy(q, p, t); + p += t; n -= t; + q += t; m -= t; + if ((s->sub.left -= t) != 0) + break; + Tracev((stderr, "inflate: stored end, %lu total out\n", + z->total_out + (q >= s->read ? q - s->read : + (s->end - s->read) + (q - s->window)))); + s->mode = s->last ? DRY : TYPE; + break; + case TABLE: + NEEDBITS(14) + s->sub.trees.table = t = (uInt)b & 0x3fff; +#ifndef PKZIP_BUG_WORKAROUND + if ((t & 0x1f) > 29 || ((t >> 5) & 0x1f) > 29) + { + s->mode = BAD; + z->msg = (char*)"too many length or distance symbols"; + r = Z_DATA_ERROR; + LEAVE + } +#endif + t = 258 + (t & 0x1f) + ((t >> 5) & 0x1f); + if ((s->sub.trees.blens = (uIntf*)ZALLOC(z, t, sizeof(uInt))) == Z_NULL) + { + r = Z_MEM_ERROR; + LEAVE + } + DUMPBITS(14) + s->sub.trees.index = 0; + Tracev((stderr, "inflate: table sizes ok\n")); + s->mode = BTREE; + case BTREE: + while (s->sub.trees.index < 4 + (s->sub.trees.table >> 10)) + { + NEEDBITS(3) + s->sub.trees.blens[border[s->sub.trees.index++]] = (uInt)b & 7; + DUMPBITS(3) + } + while (s->sub.trees.index < 19) + s->sub.trees.blens[border[s->sub.trees.index++]] = 0; + s->sub.trees.bb = 7; + t = inflate_trees_bits(s->sub.trees.blens, &s->sub.trees.bb, + &s->sub.trees.tb, s->hufts, z); + if (t != Z_OK) + { + ZFREE(z, s->sub.trees.blens); + r = t; + if (r == Z_DATA_ERROR) + s->mode = BAD; + LEAVE + } + s->sub.trees.index = 0; + Tracev((stderr, "inflate: bits tree ok\n")); + s->mode = DTREE; + case DTREE: + while (t = s->sub.trees.table, + s->sub.trees.index < 258 + (t & 0x1f) + ((t >> 5) & 0x1f)) + { + inflate_huft *h; + uInt i, j, c; + + t = s->sub.trees.bb; + NEEDBITS(t) + h = s->sub.trees.tb + ((uInt)b & inflate_mask[t]); + t = h->bits; + c = h->base; + if (c < 16) + { + DUMPBITS(t) + s->sub.trees.blens[s->sub.trees.index++] = c; + } + else /* c == 16..18 */ + { + i = c == 18 ? 7 : c - 14; + j = c == 18 ? 11 : 3; + NEEDBITS(t + i) + DUMPBITS(t) + j += (uInt)b & inflate_mask[i]; + DUMPBITS(i) + i = s->sub.trees.index; + t = s->sub.trees.table; + if (i + j > 258 + (t & 0x1f) + ((t >> 5) & 0x1f) || + (c == 16 && i < 1)) + { + ZFREE(z, s->sub.trees.blens); + s->mode = BAD; + z->msg = (char*)"invalid bit length repeat"; + r = Z_DATA_ERROR; + LEAVE + } + c = c == 16 ? s->sub.trees.blens[i - 1] : 0; + do { + s->sub.trees.blens[i++] = c; + } while (--j); + s->sub.trees.index = i; + } + } + s->sub.trees.tb = Z_NULL; + { + uInt bl, bd; + inflate_huft *tl, *td; + inflate_codes_statef *c; + + bl = 9; /* must be <= 9 for lookahead assumptions */ + bd = 6; /* must be <= 9 for lookahead assumptions */ + t = s->sub.trees.table; + t = inflate_trees_dynamic(257 + (t & 0x1f), 1 + ((t >> 5) & 0x1f), + s->sub.trees.blens, &bl, &bd, &tl, &td, + s->hufts, z); + ZFREE(z, s->sub.trees.blens); + if (t != Z_OK) + { + if (t == (uInt)Z_DATA_ERROR) + s->mode = BAD; + r = t; + LEAVE + } + Tracev((stderr, "inflate: trees ok\n")); + if ((c = inflate_codes_new(bl, bd, tl, td, z)) == Z_NULL) + { + r = Z_MEM_ERROR; + LEAVE + } + s->sub.decode.codes = c; + } + s->mode = CODES; + case CODES: + UPDATE + if ((r = inflate_codes(s, z, r)) != Z_STREAM_END) + return inflate_flush(s, z, r); + r = Z_OK; + inflate_codes_free(s->sub.decode.codes, z); + LOAD + Tracev((stderr, "inflate: codes end, %lu total out\n", + z->total_out + (q >= s->read ? q - s->read : + (s->end - s->read) + (q - s->window)))); + if (!s->last) + { + s->mode = TYPE; + break; + } + s->mode = DRY; + case DRY: + FLUSH + if (s->read != s->write) + LEAVE + s->mode = DONE; + case DONE: + r = Z_STREAM_END; + LEAVE + case BAD: + r = Z_DATA_ERROR; + LEAVE + default: + r = Z_STREAM_ERROR; + LEAVE + } +} + + +int inflate_blocks_free(s, z) +inflate_blocks_statef *s; +z_streamp z; +{ + inflate_blocks_reset(s, z, Z_NULL); + ZFREE(z, s->window); + ZFREE(z, s->hufts); + ZFREE(z, s); + Tracev((stderr, "inflate: blocks freed\n")); + return Z_OK; +} + + +void inflate_set_dictionary(s, d, n) +inflate_blocks_statef *s; +const Bytef *d; +uInt n; +{ + zmemcpy(s->window, d, n); + s->read = s->write = s->window + n; +} + + +/* Returns true if inflate is currently at the end of a block generated + * by Z_SYNC_FLUSH or Z_FULL_FLUSH. + * IN assertion: s != Z_NULL + */ +int inflate_blocks_sync_point(s) +inflate_blocks_statef *s; +{ + return s->mode == LENS; +} diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\infblock.h corman\zlib\infblock.h --- corman3\zlib\infblock.h Wed Dec 31 16:00:00 1969 +++ corman\zlib\infblock.h Mon Jul 31 07:33:09 2006 @@ -0,0 +1,39 @@ +/* infblock.h -- header to use infblock.c + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +struct inflate_blocks_state; +typedef struct inflate_blocks_state FAR inflate_blocks_statef; + +extern inflate_blocks_statef * inflate_blocks_new OF(( + z_streamp z, + check_func c, /* check function */ + uInt w)); /* window size */ + +extern int inflate_blocks OF(( + inflate_blocks_statef *, + z_streamp , + int)); /* initial return code */ + +extern void inflate_blocks_reset OF(( + inflate_blocks_statef *, + z_streamp , + uLongf *)); /* check value on output */ + +extern int inflate_blocks_free OF(( + inflate_blocks_statef *, + z_streamp)); + +extern void inflate_set_dictionary OF(( + inflate_blocks_statef *s, + const Bytef *d, /* dictionary */ + uInt n)); /* dictionary length */ + +extern int inflate_blocks_sync_point OF(( + inflate_blocks_statef *s)); diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\infcodes.c corman\zlib\infcodes.c --- corman3\zlib\infcodes.c Wed Dec 31 16:00:00 1969 +++ corman\zlib\infcodes.c Mon Jul 31 07:33:09 2006 @@ -0,0 +1,257 @@ +/* infcodes.c -- process literals and length/distance pairs + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +#include "zutil.h" +#include "inftrees.h" +#include "infblock.h" +#include "infcodes.h" +#include "infutil.h" +#include "inffast.h" + +/* simplify the use of the inflate_huft type with some defines */ +#define exop word.what.Exop +#define bits word.what.Bits + +typedef enum { /* waiting for "i:"=input, "o:"=output, "x:"=nothing */ + START, /* x: set up for LEN */ + LEN, /* i: get length/literal/eob next */ + LENEXT, /* i: getting length extra (have base) */ + DIST, /* i: get distance next */ + DISTEXT, /* i: getting distance extra */ + COPY, /* o: copying bytes in window, waiting for space */ + LIT, /* o: got literal, waiting for output space */ + WASH, /* o: got eob, possibly still output waiting */ + END, /* x: got eob and all data flushed */ + BADCODE} /* x: got error */ +inflate_codes_mode; + +/* inflate codes private state */ +struct inflate_codes_state { + + /* mode */ + inflate_codes_mode mode; /* current inflate_codes mode */ + + /* mode dependent information */ + uInt len; + union { + struct { + inflate_huft *tree; /* pointer into tree */ + uInt need; /* bits needed */ + } code; /* if LEN or DIST, where in tree */ + uInt lit; /* if LIT, literal */ + struct { + uInt get; /* bits to get for extra */ + uInt dist; /* distance back to copy from */ + } copy; /* if EXT or COPY, where and how much */ + } sub; /* submode */ + + /* mode independent information */ + Byte lbits; /* ltree bits decoded per branch */ + Byte dbits; /* dtree bits decoder per branch */ + inflate_huft *ltree; /* literal/length/eob tree */ + inflate_huft *dtree; /* distance tree */ + +}; + + +inflate_codes_statef *inflate_codes_new(bl, bd, tl, td, z) +uInt bl, bd; +inflate_huft *tl; +inflate_huft *td; /* need separate declaration for Borland C++ */ +z_streamp z; +{ + inflate_codes_statef *c; + + if ((c = (inflate_codes_statef *) + ZALLOC(z,1,sizeof(struct inflate_codes_state))) != Z_NULL) + { + c->mode = START; + c->lbits = (Byte)bl; + c->dbits = (Byte)bd; + c->ltree = tl; + c->dtree = td; + Tracev((stderr, "inflate: codes new\n")); + } + return c; +} + + +int inflate_codes(s, z, r) +inflate_blocks_statef *s; +z_streamp z; +int r; +{ + uInt j; /* temporary storage */ + inflate_huft *t; /* temporary pointer */ + uInt e; /* extra bits or operation */ + uLong b; /* bit buffer */ + uInt k; /* bits in bit buffer */ + Bytef *p; /* input data pointer */ + uInt n; /* bytes available there */ + Bytef *q; /* output window write pointer */ + uInt m; /* bytes to end of window or read pointer */ + Bytef *f; /* pointer to copy strings from */ + inflate_codes_statef *c = s->sub.decode.codes; /* codes state */ + + /* copy input/output information to locals (UPDATE macro restores) */ + LOAD + + /* process input and output based on current state */ + while (1) switch (c->mode) + { /* waiting for "i:"=input, "o:"=output, "x:"=nothing */ + case START: /* x: set up for LEN */ +#ifndef SLOW + if (m >= 258 && n >= 10) + { + UPDATE + r = inflate_fast(c->lbits, c->dbits, c->ltree, c->dtree, s, z); + LOAD + if (r != Z_OK) + { + c->mode = r == Z_STREAM_END ? WASH : BADCODE; + break; + } + } +#endif /* !SLOW */ + c->sub.code.need = c->lbits; + c->sub.code.tree = c->ltree; + c->mode = LEN; + case LEN: /* i: get length/literal/eob next */ + j = c->sub.code.need; + NEEDBITS(j) + t = c->sub.code.tree + ((uInt)b & inflate_mask[j]); + DUMPBITS(t->bits) + e = (uInt)(t->exop); + if (e == 0) /* literal */ + { + c->sub.lit = t->base; + Tracevv((stderr, t->base >= 0x20 && t->base < 0x7f ? + "inflate: literal '%c'\n" : + "inflate: literal 0x%02x\n", t->base)); + c->mode = LIT; + break; + } + if (e & 16) /* length */ + { + c->sub.copy.get = e & 15; + c->len = t->base; + c->mode = LENEXT; + break; + } + if ((e & 64) == 0) /* next table */ + { + c->sub.code.need = e; + c->sub.code.tree = t + t->base; + break; + } + if (e & 32) /* end of block */ + { + Tracevv((stderr, "inflate: end of block\n")); + c->mode = WASH; + break; + } + c->mode = BADCODE; /* invalid code */ + z->msg = (char*)"invalid literal/length code"; + r = Z_DATA_ERROR; + LEAVE + case LENEXT: /* i: getting length extra (have base) */ + j = c->sub.copy.get; + NEEDBITS(j) + c->len += (uInt)b & inflate_mask[j]; + DUMPBITS(j) + c->sub.code.need = c->dbits; + c->sub.code.tree = c->dtree; + Tracevv((stderr, "inflate: length %u\n", c->len)); + c->mode = DIST; + case DIST: /* i: get distance next */ + j = c->sub.code.need; + NEEDBITS(j) + t = c->sub.code.tree + ((uInt)b & inflate_mask[j]); + DUMPBITS(t->bits) + e = (uInt)(t->exop); + if (e & 16) /* distance */ + { + c->sub.copy.get = e & 15; + c->sub.copy.dist = t->base; + c->mode = DISTEXT; + break; + } + if ((e & 64) == 0) /* next table */ + { + c->sub.code.need = e; + c->sub.code.tree = t + t->base; + break; + } + c->mode = BADCODE; /* invalid code */ + z->msg = (char*)"invalid distance code"; + r = Z_DATA_ERROR; + LEAVE + case DISTEXT: /* i: getting distance extra */ + j = c->sub.copy.get; + NEEDBITS(j) + c->sub.copy.dist += (uInt)b & inflate_mask[j]; + DUMPBITS(j) + Tracevv((stderr, "inflate: distance %u\n", c->sub.copy.dist)); + c->mode = COPY; + case COPY: /* o: copying bytes in window, waiting for space */ +#ifndef __TURBOC__ /* Turbo C bug for following expression */ + f = (uInt)(q - s->window) < c->sub.copy.dist ? + s->end - (c->sub.copy.dist - (q - s->window)) : + q - c->sub.copy.dist; +#else + f = q - c->sub.copy.dist; + if ((uInt)(q - s->window) < c->sub.copy.dist) + f = s->end - (c->sub.copy.dist - (uInt)(q - s->window)); +#endif + while (c->len) + { + NEEDOUT + OUTBYTE(*f++) + if (f == s->end) + f = s->window; + c->len--; + } + c->mode = START; + break; + case LIT: /* o: got literal, waiting for output space */ + NEEDOUT + OUTBYTE(c->sub.lit) + c->mode = START; + break; + case WASH: /* o: got eob, possibly more output */ + if (k > 7) /* return unused byte, if any */ + { + Assert(k < 16, "inflate_codes grabbed too many bytes") + k -= 8; + n++; + p--; /* can always return one */ + } + FLUSH + if (s->read != s->write) + LEAVE + c->mode = END; + case END: + r = Z_STREAM_END; + LEAVE + case BADCODE: /* x: got error */ + r = Z_DATA_ERROR; + LEAVE + default: + r = Z_STREAM_ERROR; + LEAVE + } +#ifdef NEED_DUMMY_RETURN + return Z_STREAM_ERROR; /* Some dumb compilers complain without this */ +#endif +} + + +void inflate_codes_free(c, z) +inflate_codes_statef *c; +z_streamp z; +{ + ZFREE(z, c); + Tracev((stderr, "inflate: codes free\n")); +} diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\infcodes.h corman\zlib\infcodes.h --- corman3\zlib\infcodes.h Wed Dec 31 16:00:00 1969 +++ corman\zlib\infcodes.h Mon Jul 31 07:33:09 2006 @@ -0,0 +1,27 @@ +/* infcodes.h -- header to use infcodes.c + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +struct inflate_codes_state; +typedef struct inflate_codes_state FAR inflate_codes_statef; + +extern inflate_codes_statef *inflate_codes_new OF(( + uInt, uInt, + inflate_huft *, inflate_huft *, + z_streamp )); + +extern int inflate_codes OF(( + inflate_blocks_statef *, + z_streamp , + int)); + +extern void inflate_codes_free OF(( + inflate_codes_statef *, + z_streamp )); + diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\infutil.c corman\zlib\infutil.c --- corman3\zlib\infutil.c Wed Dec 31 16:00:00 1969 +++ corman\zlib\infutil.c Mon Jul 31 07:33:09 2006 @@ -0,0 +1,87 @@ +/* inflate_util.c -- data and routines common to blocks and codes + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +#include "zutil.h" +#include "infblock.h" +#include "inftrees.h" +#include "infcodes.h" +#include "infutil.h" + +struct inflate_codes_state {int dummy;}; /* for buggy compilers */ + +/* And'ing with mask[n] masks the lower n bits */ +uInt inflate_mask[17] = { + 0x0000, + 0x0001, 0x0003, 0x0007, 0x000f, 0x001f, 0x003f, 0x007f, 0x00ff, + 0x01ff, 0x03ff, 0x07ff, 0x0fff, 0x1fff, 0x3fff, 0x7fff, 0xffff +}; + + +/* copy as much as possible from the sliding window to the output area */ +int inflate_flush(s, z, r) +inflate_blocks_statef *s; +z_streamp z; +int r; +{ + uInt n; + Bytef *p; + Bytef *q; + + /* local copies of source and destination pointers */ + p = z->next_out; + q = s->read; + + /* compute number of bytes to copy as far as end of window */ + n = (uInt)((q <= s->write ? s->write : s->end) - q); + if (n > z->avail_out) n = z->avail_out; + if (n && r == Z_BUF_ERROR) r = Z_OK; + + /* update counters */ + z->avail_out -= n; + z->total_out += n; + + /* update check information */ + if (s->checkfn != Z_NULL) + z->adler = s->check = (*s->checkfn)(s->check, q, n); + + /* copy as far as end of window */ + zmemcpy(p, q, n); + p += n; + q += n; + + /* see if more to copy at beginning of window */ + if (q == s->end) + { + /* wrap pointers */ + q = s->window; + if (s->write == s->end) + s->write = s->window; + + /* compute bytes to copy */ + n = (uInt)(s->write - q); + if (n > z->avail_out) n = z->avail_out; + if (n && r == Z_BUF_ERROR) r = Z_OK; + + /* update counters */ + z->avail_out -= n; + z->total_out += n; + + /* update check information */ + if (s->checkfn != Z_NULL) + z->adler = s->check = (*s->checkfn)(s->check, q, n); + + /* copy */ + zmemcpy(p, q, n); + p += n; + q += n; + } + + /* update pointers */ + z->next_out = p; + s->read = q; + + /* done */ + return r; +} diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\infutil.h corman\zlib\infutil.h --- corman3\zlib\infutil.h Wed Dec 31 16:00:00 1969 +++ corman\zlib\infutil.h Mon Jul 31 07:33:09 2006 @@ -0,0 +1,98 @@ +/* infutil.h -- types and macros common to blocks and codes + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +#ifndef _INFUTIL_H +#define _INFUTIL_H + +typedef enum { + TYPE, /* get type bits (3, including end bit) */ + LENS, /* get lengths for stored */ + STORED, /* processing stored block */ + TABLE, /* get table lengths */ + BTREE, /* get bit lengths tree for a dynamic block */ + DTREE, /* get length, distance trees for a dynamic block */ + CODES, /* processing fixed or dynamic block */ + DRY, /* output remaining window bytes */ + DONE, /* finished last block, done */ + BAD} /* got a data error--stuck here */ +inflate_block_mode; + +/* inflate blocks semi-private state */ +struct inflate_blocks_state { + + /* mode */ + inflate_block_mode mode; /* current inflate_block mode */ + + /* mode dependent information */ + union { + uInt left; /* if STORED, bytes left to copy */ + struct { + uInt table; /* table lengths (14 bits) */ + uInt index; /* index into blens (or border) */ + uIntf *blens; /* bit lengths of codes */ + uInt bb; /* bit length tree depth */ + inflate_huft *tb; /* bit length decoding tree */ + } trees; /* if DTREE, decoding info for trees */ + struct { + inflate_codes_statef + *codes; + } decode; /* if CODES, current state */ + } sub; /* submode */ + uInt last; /* true if this block is the last block */ + + /* mode independent information */ + uInt bitk; /* bits in bit buffer */ + uLong bitb; /* bit buffer */ + inflate_huft *hufts; /* single malloc for tree space */ + Bytef *window; /* sliding window */ + Bytef *end; /* one byte after sliding window */ + Bytef *read; /* window read pointer */ + Bytef *write; /* window write pointer */ + check_func checkfn; /* check function */ + uLong check; /* check on output */ + +}; + + +/* defines for inflate input/output */ +/* update pointers and return */ +#define UPDBITS {s->bitb=b;s->bitk=k;} +#define UPDIN {z->avail_in=n;z->total_in+=p-z->next_in;z->next_in=p;} +#define UPDOUT {s->write=q;} +#define UPDATE {UPDBITS UPDIN UPDOUT} +#define LEAVE {UPDATE return inflate_flush(s,z,r);} +/* get bytes and bits */ +#define LOADIN {p=z->next_in;n=z->avail_in;b=s->bitb;k=s->bitk;} +#define NEEDBYTE {if(n)r=Z_OK;else LEAVE} +#define NEXTBYTE (n--,*p++) +#define NEEDBITS(j) {while(k<(j)){NEEDBYTE;b|=((uLong)NEXTBYTE)<>=(j);k-=(j);} +/* output bytes */ +#define WAVAIL (uInt)(qread?s->read-q-1:s->end-q) +#define LOADOUT {q=s->write;m=(uInt)WAVAIL;} +#define WRAP {if(q==s->end&&s->read!=s->window){q=s->window;m=(uInt)WAVAIL;}} +#define FLUSH {UPDOUT r=inflate_flush(s,z,r); LOADOUT} +#define NEEDOUT {if(m==0){WRAP if(m==0){FLUSH WRAP if(m==0) LEAVE}}r=Z_OK;} +#define OUTBYTE(a) {*q++=(Byte)(a);m--;} +/* load local pointers */ +#define LOAD {LOADIN LOADOUT} + +/* masks for lower bits (size given to avoid silly warnings with Visual C++) */ +extern uInt inflate_mask[17]; + +/* copy as much as possible from the sliding window to the output area */ +extern int inflate_flush OF(( + inflate_blocks_statef *, + z_streamp , + int)); + +struct internal_state {int dummy;}; /* for buggy compilers */ + +#endif diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\zadler32.c corman\zlib\zadler32.c --- corman3\zlib\zadler32.c Wed Dec 31 16:00:00 1969 +++ corman\zlib\zadler32.c Mon Jul 31 07:33:09 2006 @@ -0,0 +1,62 @@ +/* + * @(#)zadler32.c 1.10 98/08/17 + * + * Copyright 1996-1998 by Sun Microsystems, Inc., + * 901 San Antonio Road, Palo Alto, California, 94303, U.S.A. + * All rights reserved. + * + * This software is the confidential and proprietary information + * of Sun Microsystems, Inc. ("Confidential Information"). You + * shall not disclose such Confidential Information and shall use + * it only in accordance with the terms of the license agreement + * you entered into with Sun. + */ + +/* adler32.c -- compute the Adler-32 checksum of a data stream + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* @(#) $Id$ */ + +#include "zlib.h" + +#define BASE 65521L /* largest prime smaller than 65536 */ +#define NMAX 5552 +/* NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 */ + +#define DO1(buf,i) {s1 += buf[i]; s2 += s1;} +#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); +#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); +#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); +#define DO16(buf) DO8(buf,0); DO8(buf,8); + +/* ========================================================================= */ +uLong ZEXPORT adler32(adler, buf, len) + uLong adler; + const Bytef *buf; + uInt len; +{ + unsigned long s1 = adler & 0xffff; + unsigned long s2 = (adler >> 16) & 0xffff; + int k; + + if (buf == Z_NULL) return 1L; + + while (len > 0) { + k = len < NMAX ? len : NMAX; + len -= k; + while (k >= 16) { + DO16(buf); + buf += 16; + k -= 16; + } + if (k != 0) do { + s1 += *buf++; + s2 += s1; + } while (--k); + s1 %= BASE; + s2 %= BASE; + } + return (s2 << 16) | s1; +} diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\zcrc32.c corman\zlib\zcrc32.c --- corman3\zlib\zcrc32.c Wed Dec 31 16:00:00 1969 +++ corman\zlib\zcrc32.c Mon Jul 31 07:33:09 2006 @@ -0,0 +1,176 @@ +/* + * @(#)zcrc32.c 1.13 98/08/17 + * + * Copyright 1996-1998 by Sun Microsystems, Inc., + * 901 San Antonio Road, Palo Alto, California, 94303, U.S.A. + * All rights reserved. + * + * This software is the confidential and proprietary information + * of Sun Microsystems, Inc. ("Confidential Information"). You + * shall not disclose such Confidential Information and shall use + * it only in accordance with the terms of the license agreement + * you entered into with Sun. + */ + +/* crc32.c -- compute the CRC-32 of a data stream + * Copyright (C) 1995-1998 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* @(#) $Id$ */ + +#include "zlib.h" + +#define local static + +#ifdef DYNAMIC_CRC_TABLE + +local int crc_table_empty = 1; +local uLongf crc_table[256]; +local void make_crc_table OF((void)); + +/* + Generate a table for a byte-wise 32-bit CRC calculation on the polynomial: + x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. + + Polynomials over GF(2) are represented in binary, one bit per coefficient, + with the lowest powers in the most significant bit. Then adding polynomials + is just exclusive-or, and multiplying a polynomial by x is a right shift by + one. If we call the above polynomial p, and represent a byte as the + polynomial q, also with the lowest power in the most significant bit (so the + byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p, + where a mod b means the remainder after dividing a by b. + + This calculation is done using the shift-register method of multiplying and + taking the remainder. The register is initialized to zero, and for each + incoming bit, x^32 is added mod p to the register if the bit is a one (where + x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by + x (which is shifting right by one and adding x^32 mod p if the bit shifted + out is a one). We start with the highest power (least significant bit) of + q and repeat for all eight bits of q. + + The table is simply the CRC of all possible eight bit values. This is all + the information needed to generate CRC's on data a byte at a time for all + combinations of CRC register values and incoming bytes. +*/ +local void make_crc_table() +{ + uLong c; + int n, k; + uLong poly; /* polynomial exclusive-or pattern */ + /* terms of polynomial defining this crc (except x^32): */ + static const Byte p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26}; + + /* make exclusive-or pattern from polynomial (0xedb88320UL) */ + poly = 0UL; + for (n = 0; n < sizeof(p)/sizeof(Byte); n++) + poly |= 1L << (31 - p[n]); + + for (n = 0; n < 256; n++) + { + c = (uLong)n; + for (k = 0; k < 8; k++) + c = c & 1 ? poly ^ (c >> 1) : c >> 1; + crc_table[n] = c; + } + crc_table_empty = 0; +} +#else +/* ======================================================================== + * Table of CRC-32's of all single-byte values (made by make_crc_table) + */ +local const uLongf crc_table[256] = { + 0x00000000UL, 0x77073096UL, 0xee0e612cUL, 0x990951baUL, 0x076dc419UL, + 0x706af48fUL, 0xe963a535UL, 0x9e6495a3UL, 0x0edb8832UL, 0x79dcb8a4UL, + 0xe0d5e91eUL, 0x97d2d988UL, 0x09b64c2bUL, 0x7eb17cbdUL, 0xe7b82d07UL, + 0x90bf1d91UL, 0x1db71064UL, 0x6ab020f2UL, 0xf3b97148UL, 0x84be41deUL, + 0x1adad47dUL, 0x6ddde4ebUL, 0xf4d4b551UL, 0x83d385c7UL, 0x136c9856UL, + 0x646ba8c0UL, 0xfd62f97aUL, 0x8a65c9ecUL, 0x14015c4fUL, 0x63066cd9UL, + 0xfa0f3d63UL, 0x8d080df5UL, 0x3b6e20c8UL, 0x4c69105eUL, 0xd56041e4UL, + 0xa2677172UL, 0x3c03e4d1UL, 0x4b04d447UL, 0xd20d85fdUL, 0xa50ab56bUL, + 0x35b5a8faUL, 0x42b2986cUL, 0xdbbbc9d6UL, 0xacbcf940UL, 0x32d86ce3UL, + 0x45df5c75UL, 0xdcd60dcfUL, 0xabd13d59UL, 0x26d930acUL, 0x51de003aUL, + 0xc8d75180UL, 0xbfd06116UL, 0x21b4f4b5UL, 0x56b3c423UL, 0xcfba9599UL, + 0xb8bda50fUL, 0x2802b89eUL, 0x5f058808UL, 0xc60cd9b2UL, 0xb10be924UL, + 0x2f6f7c87UL, 0x58684c11UL, 0xc1611dabUL, 0xb6662d3dUL, 0x76dc4190UL, + 0x01db7106UL, 0x98d220bcUL, 0xefd5102aUL, 0x71b18589UL, 0x06b6b51fUL, + 0x9fbfe4a5UL, 0xe8b8d433UL, 0x7807c9a2UL, 0x0f00f934UL, 0x9609a88eUL, + 0xe10e9818UL, 0x7f6a0dbbUL, 0x086d3d2dUL, 0x91646c97UL, 0xe6635c01UL, + 0x6b6b51f4UL, 0x1c6c6162UL, 0x856530d8UL, 0xf262004eUL, 0x6c0695edUL, + 0x1b01a57bUL, 0x8208f4c1UL, 0xf50fc457UL, 0x65b0d9c6UL, 0x12b7e950UL, + 0x8bbeb8eaUL, 0xfcb9887cUL, 0x62dd1ddfUL, 0x15da2d49UL, 0x8cd37cf3UL, + 0xfbd44c65UL, 0x4db26158UL, 0x3ab551ceUL, 0xa3bc0074UL, 0xd4bb30e2UL, + 0x4adfa541UL, 0x3dd895d7UL, 0xa4d1c46dUL, 0xd3d6f4fbUL, 0x4369e96aUL, + 0x346ed9fcUL, 0xad678846UL, 0xda60b8d0UL, 0x44042d73UL, 0x33031de5UL, + 0xaa0a4c5fUL, 0xdd0d7cc9UL, 0x5005713cUL, 0x270241aaUL, 0xbe0b1010UL, + 0xc90c2086UL, 0x5768b525UL, 0x206f85b3UL, 0xb966d409UL, 0xce61e49fUL, + 0x5edef90eUL, 0x29d9c998UL, 0xb0d09822UL, 0xc7d7a8b4UL, 0x59b33d17UL, + 0x2eb40d81UL, 0xb7bd5c3bUL, 0xc0ba6cadUL, 0xedb88320UL, 0x9abfb3b6UL, + 0x03b6e20cUL, 0x74b1d29aUL, 0xead54739UL, 0x9dd277afUL, 0x04db2615UL, + 0x73dc1683UL, 0xe3630b12UL, 0x94643b84UL, 0x0d6d6a3eUL, 0x7a6a5aa8UL, + 0xe40ecf0bUL, 0x9309ff9dUL, 0x0a00ae27UL, 0x7d079eb1UL, 0xf00f9344UL, + 0x8708a3d2UL, 0x1e01f268UL, 0x6906c2feUL, 0xf762575dUL, 0x806567cbUL, + 0x196c3671UL, 0x6e6b06e7UL, 0xfed41b76UL, 0x89d32be0UL, 0x10da7a5aUL, + 0x67dd4accUL, 0xf9b9df6fUL, 0x8ebeeff9UL, 0x17b7be43UL, 0x60b08ed5UL, + 0xd6d6a3e8UL, 0xa1d1937eUL, 0x38d8c2c4UL, 0x4fdff252UL, 0xd1bb67f1UL, + 0xa6bc5767UL, 0x3fb506ddUL, 0x48b2364bUL, 0xd80d2bdaUL, 0xaf0a1b4cUL, + 0x36034af6UL, 0x41047a60UL, 0xdf60efc3UL, 0xa867df55UL, 0x316e8eefUL, + 0x4669be79UL, 0xcb61b38cUL, 0xbc66831aUL, 0x256fd2a0UL, 0x5268e236UL, + 0xcc0c7795UL, 0xbb0b4703UL, 0x220216b9UL, 0x5505262fUL, 0xc5ba3bbeUL, + 0xb2bd0b28UL, 0x2bb45a92UL, 0x5cb36a04UL, 0xc2d7ffa7UL, 0xb5d0cf31UL, + 0x2cd99e8bUL, 0x5bdeae1dUL, 0x9b64c2b0UL, 0xec63f226UL, 0x756aa39cUL, + 0x026d930aUL, 0x9c0906a9UL, 0xeb0e363fUL, 0x72076785UL, 0x05005713UL, + 0x95bf4a82UL, 0xe2b87a14UL, 0x7bb12baeUL, 0x0cb61b38UL, 0x92d28e9bUL, + 0xe5d5be0dUL, 0x7cdcefb7UL, 0x0bdbdf21UL, 0x86d3d2d4UL, 0xf1d4e242UL, + 0x68ddb3f8UL, 0x1fda836eUL, 0x81be16cdUL, 0xf6b9265bUL, 0x6fb077e1UL, + 0x18b74777UL, 0x88085ae6UL, 0xff0f6a70UL, 0x66063bcaUL, 0x11010b5cUL, + 0x8f659effUL, 0xf862ae69UL, 0x616bffd3UL, 0x166ccf45UL, 0xa00ae278UL, + 0xd70dd2eeUL, 0x4e048354UL, 0x3903b3c2UL, 0xa7672661UL, 0xd06016f7UL, + 0x4969474dUL, 0x3e6e77dbUL, 0xaed16a4aUL, 0xd9d65adcUL, 0x40df0b66UL, + 0x37d83bf0UL, 0xa9bcae53UL, 0xdebb9ec5UL, 0x47b2cf7fUL, 0x30b5ffe9UL, + 0xbdbdf21cUL, 0xcabac28aUL, 0x53b39330UL, 0x24b4a3a6UL, 0xbad03605UL, + 0xcdd70693UL, 0x54de5729UL, 0x23d967bfUL, 0xb3667a2eUL, 0xc4614ab8UL, + 0x5d681b02UL, 0x2a6f2b94UL, 0xb40bbe37UL, 0xc30c8ea1UL, 0x5a05df1bUL, + 0x2d02ef8dUL +}; +#endif + +/* ========================================================================= + * This function can be used by asm versions of crc32() + */ +const uLongf * ZEXPORT get_crc_table() +{ +#ifdef DYNAMIC_CRC_TABLE + if (crc_table_empty) make_crc_table(); +#endif + return (const uLongf *)crc_table; +} + +/* ========================================================================= */ +#define DO1(buf) crc = crc_table[((int)crc ^ (*buf++)) & 0xff] ^ (crc >> 8); +#define DO2(buf) DO1(buf); DO1(buf); +#define DO4(buf) DO2(buf); DO2(buf); +#define DO8(buf) DO4(buf); DO4(buf); + +/* ========================================================================= */ +uLong ZEXPORT crc32(crc, buf, len) + uLong crc; + const Bytef *buf; + uInt len; +{ + if (buf == Z_NULL) return 0UL; +#ifdef DYNAMIC_CRC_TABLE + if (crc_table_empty) + make_crc_table(); +#endif + crc = crc ^ 0xffffffffUL; + while (len >= 8) + { + DO8(buf); + len -= 8; + } + if (len) do { + DO1(buf); + } while (--len); + return crc ^ 0xffffffffUL; +} Binary files corman3\zlib\zlib.lib and corman\zlib\zlib.lib differ diff -NrubB --exclude=.svn --exclude=*.fasl --exclude=*.*~ --exclude=*.bak --exclude=*.dll --exclude=*.img --exclude=*.exe --exclude=*.pdb --exclude=*.ncb --exclude=*.log --exclude=*.vcproj corman3\zlib\zlib.vcproj.CORMAN-R-XP.rcorman.user corman\zlib\zlib.vcproj.CORMAN-R-XP.rcorman.user --- corman3\zlib\zlib.vcproj.CORMAN-R-XP.rcorman.user Thu Sep 14 17:40:20 2006 +++ corman\zlib\zlib.vcproj.CORMAN-R-XP.rcorman.user Wed Dec 31 16:00:00 1969 @@ -1,37 +0,0 @@ - - - - - - - -