r2948: *** empty log message ***

diff --git a/attrib-class.lisp b/attrib-class.lisp
new file mode 100644 (file)
index 0000000..4d88e66
--- /dev/null
+++ b/attrib-class.lisp
@@ -0,0 +1,124 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          attrib-class.lisp
+;;;; Purpose:       Defines metaclass allowing use of attributes on slots
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: attrib-class.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+;;;; Defines a metaclass that allows the use of attributes (or subslots)
+;;;; on slots. Based on example in AMOP, but modified to use ACL's MOP.
+
+(in-package :genutils)
+
+(defclass attributes-dsd (mop::standard-direct-slot-definition)
+  ((attributes :initarg :attributes :initform nil 
+              :accessor attributes)))
+
+(defclass attributes-esd (mop::standard-effective-slot-definition)
+  ((attributes :initarg :attributes :initform nil 
+              :accessor slot-definition-attributes)))
+
+
+(defclass attributes-class (mop::standard-class)
+  ()
+  )
+
+(defmethod mop::direct-slot-definition-class ((cl attributes-class) 
+                                             &rest iargs &key attributes)
+  (declare (ignorable attributes))
+;;  (format t "attributes:~s iargs:~s~%" attributes iargs)
+  (find-class 'attributes-dsd))
+
+
+(defmethod mop::compute-effective-slot-definition :around
+          ((cl attributes-class) slot dsds)
+  (declare (ignorable slot))
+  (apply
+   #'make-instance 'attributes-esd 
+   :attributes (remove-duplicates (gu:mapappend #'attributes dsds))
+   (excl::compute-effective-slot-definition-initargs cl dsds))
+  )
+
+
+#+ignore
+(defmethod mop::compute-effective-slot-definition ((cl attributes-class) slot dsds)
+  (declare (ignorable slot))
+  (let ((normal-slot (call-next-method)))
+    (setf (slot-definition-attributes normal-slot)
+      (remove-duplicates
+       (mapappend #'slot-definition-attributes dsds)))
+    normal-slot))
+
+
+(defmethod mop::compute-slots ((class attributes-class))
+  (let* ((normal-slots (call-next-method))
+        (alist
+         (mapcar
+          #'(lambda (slot)
+              (let ((attr-list (mapcar #'(lambda (attr) (cons attr nil))
+                                       (slot-definition-attributes slot))))
+                (when attr-list
+                  (cons (mop::slot-definition-name slot) attr-list))))
+          normal-slots)))
+    (setq alist (delete nil alist))
+    (cons (mop::make-instance 'mop::standard-effective-slot-definition
+           :name 'all-attributes
+           :initform `',alist
+           :initfunction #'(lambda () alist))
+         normal-slots)))
+  
+(defun slot-attribute (instance slot-name attribute)
+  (cdr (slot-attribute-bucket instance slot-name attribute)))
+
+(defun (setf slot-attribute) (new-value instance slot-name attribute)
+  (setf (cdr (slot-attribute-bucket instance slot-name attribute))
+    new-value))
+
+(defun slot-attribute-bucket (instance slot-name attribute)
+  (let* ((all-buckets (slot-value instance 'all-attributes))
+        (slot-bucket (assoc slot-name all-buckets)))
+    (unless slot-bucket
+      (error "The slot named ~S of ~S has no attributes."
+            slot-name instance))
+    (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
+      (unless attr-bucket
+       (error "The slot named ~S of ~S has no attributes named ~S."
+              slot-name instance attribute))
+      attr-bucket)))
+
+
+#||
+(in-package :genutils)
+
+(defclass credit-rating ()
+  ((level :attributes (date-set time-set))
+   (id :attributes (person-setting)))
+  (:metaclass genutils:attributes-class))
+(defparameter cr (make-instance 'credit-rating))
+
+(format t "~&date-set: ~a" (gu:slot-attribute cr 'level 'date-set))
+(setf (gu:slot-attribute cr 'level 'date-set) "12/15/1990")
+(format t "~&date-set: ~a" (gu:slot-attribute cr 'level 'date-set))
+  
+(defclass monitored-credit-rating (credit-rating)
+  ((level :attributes (last-checked interval date-set))
+   (cc :initarg :cc)
+   (id :attributes (verified))
+   )
+  (:metaclass gu:attributes-class))
+(defparameter mcr (make-instance 'monitored-credit-rating))
+
+(setf (gu:slot-attribute mcr 'level 'date-set) "01/05/2002")
+(format t "~&date-set for mcr: ~a" (gu:slot-attribute mcr 'level 'date-set))
+
+||#

diff --git a/buff-input.lisp b/buff-input.lisp
new file mode 100644 (file)
index 0000000..fe3f311
--- /dev/null
+++ b/buff-input.lisp
@@ -0,0 +1,177 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          buff-input.lisp
+;;;; Purpose:       Buffered line input
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: buff-input.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(declaim (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+
+(defconstant +max-field+ 10000)
+(defconstant +max-fields-per-line+ 20)
+(defconstant +field-delim+ #\|)
+(defconstant +eof-char+ #\rubout)
+(defconstant +newline+ #\Newline)
+
+(declaim (type character +eof-char+ +field-delim+ +newline+)
+        (type fixnum +max-field+ +max-fields-per-line+))
+
+;; Buffered fields parsing function
+;; Uses fill-pointer for size
+
+(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+) 
+                                  (max-field-len +max-field+))
+  (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
+    (dotimes (i +max-fields-per-line+)
+      (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
+    bufs))
+
+(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+))
+  "Read a line from a stream into a field buffers"
+  (declare (type base-char field-delim)
+          (type vector fields))
+  (setf (fill-pointer fields) 0)
+  (do ((ifield 0 (1+ ifield))
+       (linedone nil)
+       (eof nil))
+      (linedone (if eof 'eof fields))
+    (declare (type fixnum ifield)
+            (type boolean linedone eof))
+    (let ((field (aref fields ifield)))
+      (declare (type base-string field))
+      (do ((ipos 0)
+          (fielddone nil)
+          (rc (read-char strm nil +eof-char+)
+             (read-char strm nil +eof-char+)))
+         (fielddone (unread-char rc strm))
+       (declare (type fixnum ipos)
+                (type base-char rc)
+                (type boolean fielddone))
+       (cond
+        ((char= rc field-delim)
+         (setf (fill-pointer field) ipos)
+         (setq fielddone t))
+        ((char= rc +newline+)
+         (setf (fill-pointer field) ipos)
+         (setf (fill-pointer fields) ifield)
+         (setq fielddone t)
+         (setq linedone t))
+        ((char= rc +eof-char+)
+         (setf (fill-pointer field) ipos)
+         (setf (fill-pointer fields) ifield)
+         (setq fielddone t)
+         (setq linedone t)
+         (setq eof t))
+        (t
+         (setf (char field ipos) rc)
+         (incf ipos)))))))
+
+;; Buffered fields parsing
+;; Does not use fill-pointer
+;; Returns 2 values -- string array and length array
+(defstruct field-buffers 
+  (nfields 0 :type fixnum)
+  (buffers)
+  (field-lengths))
+
+(defmethod print-object ((f field-buffers) s)
+  (format s "#<~d>~%" (field-buffers-nfields f)))
+   
+(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+) 
+                                  (max-field-len +max-field+))
+  (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
+       (bufstruct (make-field-buffers)))
+    (dotimes (i +max-fields-per-line+)
+      (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
+    (setf (field-buffers-buffers bufstruct) bufs)
+    (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+ 
+                                                             :element-type 'fixnum :fill-pointer nil :adjustable nil))
+    (setf (field-buffers-nfields bufstruct) 0)
+    bufstruct))
+
+
+(defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+))
+  "Read a line from a stream into a field buffers"
+  (declare (character field-delim))
+  (setf (field-buffers-nfields fields) 0)
+  (do ((ifield 0 (1+ ifield))
+       (linedone nil)
+       (eof nil))
+      (linedone (if eof 'eof fields))
+    (declare (fixnum ifield)
+            (t linedone eof))
+    (let ((field (aref (field-buffers-buffers fields) ifield)))
+      (declare (simple-string field))
+      (do ((ipos 0)
+          (fielddone nil)
+          (rc (read-char strm nil +eof-char+)
+             (read-char strm nil +eof-char+)))
+         (fielddone (unread-char rc strm))
+       (declare (fixnum ipos)
+                (character rc)
+                (t fielddone))
+       (cond
+        ((char= rc field-delim)
+         (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+         (setq fielddone t))
+        ((char= rc +newline+)
+         (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+         (setf (field-buffers-nfields fields) ifield)
+         (setq fielddone t)
+         (setq linedone t))
+        ((char= rc +eof-char+)
+         (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+         (setf (field-buffers-nfields fields) ifield)
+         (setq fielddone t)
+         (setq linedone t)
+         (setq eof t))
+        (t
+         (setf (char field ipos) rc)
+         (incf ipos)))))))
+
+(defun bfield (fields i)
+  (if (>= i (field-buffers-nfields fields))
+      nil
+    (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i))))
+
+;;; Buffered line parsing function
+
+(defconstant +max-line+ 20000)
+(let ((linebuffer (make-array +max-line+
+                             :element-type 'character
+                             :fill-pointer 0)))
+  (defun read-buffered-line (strm)
+    "Read a line from astream into a vector buffer"
+    (let ((pos 0)
+         (done nil))
+      (declare (fixnum pos) (t done))
+      (setf (fill-pointer linebuffer) 0)
+      (do ((c (read-char strm nil +eof-char+)
+             (read-char strm nil +eof-char+)))
+         (done (progn
+                 (unless (eql c +eof-char+) (unread-char c strm))
+                 (if (eql c +eof-char+) 'eof linebuffer)))
+       (declare (character c))
+       (cond
+       ((char= c #\Newline)
+        (unless (zerop pos)
+          (setf (fill-pointer linebuffer) (1- pos)))
+        (setf done t))
+       ((char= +eof-char+)
+        (setf done t))
+       (t
+        (setf (char linebuffer pos) c)
+        (incf pos)))))))
+

diff --git a/cl-symbols.lisp b/cl-symbols.lisp
new file mode 100644 (file)
index 0000000..3da0a0a
--- /dev/null
+++ b/cl-symbols.lisp
@@ -0,0 +1,43 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cl-symbols.lisp
+;;;; Purpose:       Returns all defined Common Lisp symbols
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: cl-symbols.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defun cl-symbols ()
+  (append (cl-variables) (cl-functions)))
+
+(defun cl-variables ()
+  (let ((vars '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+         (find-symbol (symbol-name s) 'common-lisp)
+       (when (and (or (eq status :external)
+                      (eq status :internal))
+                  (boundp sym))
+         (push sym vars))))
+    (nreverse vars)))
+
+(defun cl-functions ()
+  (let ((funcs '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) 'common-lisp)
+       (when (and (or (eq status :external)
+                      (eq status :internal))
+                  (fboundp sym))
+         (push sym funcs))))
+    (nreverse funcs)))

diff --git a/debian/changelog b/debian/changelog
new file mode 100644 (file)
index 0000000..0ede4eb
--- /dev/null
+++ b/debian/changelog
@@ -0,0 +1,6 @@
+cl-kmrcl (1.0-1) unstable; urgency=low
+
+  * Initial Release.
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Sat,  5 Oct 2002 13:19:33 -0600
+

diff --git a/debian/control b/debian/control
new file mode 100644 (file)
index 0000000..fd7763d
--- /dev/null
+++ b/debian/control
@@ -0,0 +1,15 @@
+Source: cl-kmrcl
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+Build-Depends-Indep: debhelper (>= 4.0.0)
+Standards-Version: 3.5.7.0
+
+Package: cl-kmrcl
+Architecture: all
+Depends: ${shlibs:Depends}
+Description: General Utilities for Common Lisp Programs
+ This package includes general purpose utilities for Common Lisp
+ programs. It is packages for Debian primarily to support more complex
+ Common Lisp packages by the upstream author Kevin Rosenberg.
+

diff --git a/debian/copyright b/debian/copyright
new file mode 100644 (file)
index 0000000..f0dbd2f
--- /dev/null
+++ b/debian/copyright
@@ -0,0 +1,15 @@
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org> on
+Sat, 5 Oct 2002 13:19:33 -0600.
+
+It was downloaded from ftp://kmrcl.b9.com
+
+Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
+
+Changes compared to upstream: none
+ 
+Copyright:
+
+Copyright (C) 2000-2002 by Kevin M. Rosenberg.
+It is governed by the GNU GPL license, a copy of which
+is located on your Debian file system as /usr/share/common-licenses/GPL.
+

diff --git a/debian/postinst b/debian/postinst
new file mode 100755 (executable)
index 0000000..a10eaba
--- /dev/null
+++ b/debian/postinst
@@ -0,0 +1,46 @@
+#! /bin/sh
+# postinst script for cl-kmrcl
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=kmrcl
+
+# summary of how this script can be called:
+#        * <postinst> `configure' <most-recently-configured-version>
+#        * <old-postinst> `abort-upgrade' <new version>
+#        * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+#          <new-version>
+#        * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+#          <failed-install-package> <version> `removing'
+#          <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+#     Any necessary prompting should almost always be confined to the
+#     post-installation script, and should be protected with a conditional
+#     so that unnecessary prompting doesn't happen if a package's
+#     installation fails and the `postinst' is called with `abort-upgrade',
+#     `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+    configure)
+       /usr/sbin/register-common-lisp-source ${LISP_PKG}
+       ;;
+    abort-upgrade|abort-remove|abort-deconfigure)
+       ;;
+    *)
+        echo "postinst called with unknown argument \`$1'" >&2
+        exit 1
+       ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0

diff --git a/debian/prerm b/debian/prerm
new file mode 100755 (executable)
index 0000000..1c05eea
--- /dev/null
+++ b/debian/prerm
@@ -0,0 +1,42 @@
+#! /bin/sh
+# prerm script for cl-kmrcl
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=kmrcl
+
+# summary of how this script can be called:
+#        * <prerm> `remove'
+#        * <old-prerm> `upgrade' <new-version>
+#        * <new-prerm> `failed-upgrade' <old-version>
+#        * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+#        * <deconfigured's-prerm> `deconfigure' `in-favour'
+#          <package-being-installed> <version> `removing'
+#          <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+    remove|upgrade|deconfigure)
+       /usr/sbin/unregister-common-lisp-source ${LISP_PKG}
+        ;;
+    failed-upgrade)
+        ;;
+    *)
+        echo "prerm called with unknown argument \`$1'" >&2
+        exit 1
+    ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+

diff --git a/debian/rules b/debian/rules
new file mode 100755 (executable)
index 0000000..fa61826
--- /dev/null
+++ b/debian/rules
@@ -0,0 +1,82 @@
+#!/usr/bin/make -f
+
+export DH_COMPAT=4
+
+pkg    := kmrcl
+debpkg  := cl-kmrcl
+
+
+clc-source     := usr/share/common-lisp/source
+clc-systems    := usr/share/common-lisp/systems
+clc-kmrcl      := $(clc-source)/$(pkg)
+
+doc-dir                := usr/share/doc/$(debpkg)
+
+
+configure: configure-stamp
+configure-stamp:
+       dh_testdir
+       # Add here commands to configure the package.
+
+       touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp 
+       dh_testdir
+       # Add here commands to compile the package.
+       touch build-stamp
+
+clean:
+       dh_testdir
+       dh_testroot
+       rm -f build-stamp configure-stamp
+       # Add here commands to clean up after the build process.
+       rm -f debian/cl-kmrcl.postinst.* debian/cl-kmrcl.prerm.*
+       dh_clean
+
+install: build
+       dh_testdir
+       dh_testroot
+       dh_clean -k
+       # Add here commands to install the package into debian/kmrcl.
+       dh_installdirs $(clc-systems) $(clc-kmrcl) $(doc-dir)
+       dh_install kmrcl.asd $(shell echo *.lisp) $(clc-kmrcl)
+       dh_link $(clc-kmrcl)/kmrcl.asd $(clc-systems)/kmrcl.asd
+
+# Build architecture-independent files here.
+binary-indep: build install
+
+
+# Build architecture-dependent files here.
+binary-arch: build install
+       dh_testdir
+       dh_testroot
+#      dh_installdebconf       
+       dh_installdocs
+#      dh_installmenu
+#      dh_installlogrotate
+#      dh_installemacsen
+#      dh_installpam
+#      dh_installmime
+#      dh_installinit
+#      dh_installcron
+#      dh_installman
+#      dh_installinfo
+#      dh_undocumented
+       dh_installchangelogs
+       dh_strip
+       dh_compress
+       dh_fixperms
+#      dh_makeshlibs
+       dh_installdeb
+#      dh_perl
+       dh_shlibdeps
+       dh_gencontrol
+       dh_md5sums
+       dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
+

diff --git a/genutils.lisp b/genutils.lisp
new file mode 100644 (file)
index 0000000..e35f23d
--- /dev/null
+++ b/genutils.lisp
@@ -0,0 +1,752 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          genutils.lisp
+;;;; Purpose:       Main general utility functions for GENUTILS package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: genutils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+
+(in-package :genutils)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+(defmacro bind-when ((bind-var boundForm) &body body)
+  `(let ((,bind-var ,boundForm))
+      (declare (ignore-if-unused ,bind-var))
+      (when ,bind-var
+        ,@body)))
+  
+(defmacro bind-if ((bind-var boundForm) yup &optional nope)
+  `(let ((,bind-var ,boundForm))
+      (if ,bind-var
+         ,yup
+         ,nope)))
+
+;; Anaphoric macros
+
+(defmacro aif (test then &optional else)
+  `(let ((it ,test))
+     (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+  `(aif ,test-form
+        (progn ,@body)))
+
+(defmacro awhile (expr &body body)
+  `(do ((it ,expr ,expr))
+       ((not it))
+     ,@body))
+
+(defmacro aand (&rest args)
+  (cond ((null args) t)
+        ((null (cdr args)) (car args))
+        (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acond (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses))
+            (sym (gensym)))
+        `(let ((,sym ,(car cl1)))
+           (if ,sym
+               (let ((it ,sym)) ,@(cdr cl1))
+               (acond ,@(cdr clauses)))))))
+
+(defmacro alambda (parms &body body)
+  `(labels ((self ,parms ,@body))
+     #'self))
+
+
+(defmacro aif2 (test &optional then else)
+  (let ((win (gensym)))
+    `(multiple-value-bind (it ,win) ,test
+       (if (or it ,win) ,then ,else))))
+
+(defmacro awhen2 (test &body body)
+  `(aif2 ,test
+         (progn ,@body)))
+
+(defmacro awhile2 (test &body body)
+  (let ((flag (gensym)))
+    `(let ((,flag t))
+       (while ,flag
+         (aif2 ,test
+               (progn ,@body)
+               (setq ,flag nil))))))
+
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses))
+            (val (gensym))
+            (win (gensym)))
+        `(multiple-value-bind (,val ,win) ,(car cl1)
+           (if (or ,val ,win)
+               (let ((it ,val)) ,@(cdr cl1))
+               (acond2 ,@(cdr clauses)))))))
+
+
+;; Debugging 
+
+(defmacro mac (expr)
+"Expand a macro"
+  `(pprint (macroexpand-1 ',expr)))
+
+(defmacro print-form-and-results (form)
+  `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
+
+(defun show (&optional (what :variables) (package *package*))
+  (ecase what
+    (:variables (show-variables package))
+    (:functions (show-functions package))))
+
+(defun show-variables (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                    (eq status :internal))
+                (boundp sym))
+       (format t "~&Symbol ~S~T -> ~S~%"
+               sym
+               (symbol-value sym))))))
+
+(defun show-functions (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                    (eq status :internal))
+                (fboundp sym))
+       (format t "~&Function ~S~T -> ~S~%"
+               sym
+               (symbol-function sym))))))
+
+#+allegro
+(ff:def-foreign-call (memory-status-dump "memory_status_dump")
+    ()
+  :strings-convert t)
+
+
+;; Ensure functions
+
+(defmacro ensure-integer (obj)
+  "Ensure object is an integer. If it is a string, then parse it"
+  `(if (stringp ,obj)
+      (parse-integer ,obj)
+    ,obj))
+
+;; Lists
+
+(defun mklist (obj)
+  "Make into list if atom"
+  (if (listp obj) obj (list obj)))
+
+(defun filter (fn lst)
+  "Filter a list by function, eliminate elements where fn returns nil"
+  (let ((acc nil))
+    (dolist (x lst)
+      (let ((val (funcall fn x)))
+        (if val (push val acc))))
+    (nreverse acc)))
+
+
+;; Functions
+
+(defun memo-proc (fn)
+  "Memoize results of call to fn, returns a closure with hash-table"
+  (let ((cache (make-hash-table :test #'equal)))
+    #'(lambda (&rest args)
+        (multiple-value-bind (val foundp) (gethash args cache)
+          (if foundp
+              val
+              (setf (gethash args cache) 
+                    (apply fn args)))))))
+
+(defun memoize (fn-name)
+  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
+
+(defmacro defun-memo (fn args &body body)
+  "Define a memoized function"
+  `(memoize (defun ,fn ,args . ,body)))
+
+(defmacro _f (op place &rest args)
+  (multiple-value-bind (vars forms var set access) 
+                       (get-setf-expansion place)
+    `(let* (,@(mapcar #'list vars forms)
+            (,(car var) (,op ,access ,@args)))
+       ,set)))
+
+(defun compose (&rest fns)
+  (if fns
+      (let ((fn1 (car (last fns)))
+            (fns (butlast fns)))
+        #'(lambda (&rest args)
+            (reduce #'funcall fns 
+                    :from-end t
+                    :initial-value (apply fn1 args))))
+      #'identity))
+
+;;; Loop macros
+
+(defmacro until (test &body body)
+  `(do ()
+       (,test)
+     ,@body))
+
+(defmacro while (test &body body)
+  `(do ()
+       ((not ,test))
+     ,@body))
+
+(defmacro for ((var start stop) &body body)
+  (let ((gstop (gensym)))
+    `(do ((,var ,start (1+ ,var))
+          (,gstop ,stop))
+         ((> ,var ,gstop))
+       ,@body)))
+
+
+;;; Keyword functions
+
+(defun remove-keyword (key arglist)
+  (loop for sublist = arglist then rest until (null sublist)
+       for (elt arg . rest) = sublist
+       unless (eq key elt) append (list elt arg)))
+
+(defun remove-keywords (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)))
+
+(defmacro in (obj &rest choices)
+  (let ((insym (gensym)))
+    `(let ((,insym ,obj))
+       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
+                     choices)))))
+
+(defmacro mean (&rest args)
+  `(/ (+ ,@args) ,(length args)))
+
+(defmacro with-gensyms (syms &body body)
+  `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+         syms)
+     ,@body))
+
+
+;;; Mapping
+
+(defun mapappend (fn list)
+  (apply #'append (mapcar fn list)))
+
+
+(defun mapcar-append-string-nontailrec (func v)
+"Concatenate results of mapcar lambda calls"  
+  (aif (car v)
+       (concatenate 'string (funcall func it)
+                   (mapcar-append-string-nontailrec func (cdr v)))
+       ""))
+
+
+(defun mapcar-append-string (func v &optional (accum ""))
+"Concatenate results of mapcar lambda calls"  
+  (aif (car v)
+       (mapcar-append-string 
+       func 
+       (cdr v) 
+       (concatenate 'string accum (funcall func it)))
+       accum))
+
+
+(defun mapcar2-append-string-nontailrec (func la lb)
+"Concatenate results of mapcar lambda call's over two lists"  
+  (let ((a (car la))
+       (b (car lb)))
+    (if (and a b)
+      (concatenate 'string (funcall func a b)
+                  (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
+      "")))
+  
+(defun mapcar2-append-string (func la lb &optional (accum ""))
+"Concatenate results of mapcar lambda call's over two lists"  
+  (let ((a (car la))
+       (b (car lb)))
+    (if (and a b)
+       (mapcar2-append-string 
+        func 
+        (cdr la) 
+        (cdr lb)
+        (concatenate 'string accum (funcall func a b)))
+      accum)))
+  
+;;; Strings
+
+(defmacro string-append (outputstr &rest args)
+  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defmacro string-field-append (outputstr &rest args)
+  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defun list-to-string (lst)
+  "Converts a list to a string, doesn't include any delimiters between elements"
+  (format nil "~{~A~}" lst))
+
+(defun count-string-words (str)
+  (declare (simple-string str)
+          (optimize (speed 3) (safety 0)))
+  (let ((n-words 0)
+       (in-word nil))
+    (declare (fixnum n-words))
+    (dotimes (i (length str))
+      (let ((ch (char str i)))
+       (declare (character ch))
+       (if (alphanumericp ch)
+           (unless in-word
+             (incf n-words)
+             (setq in-word t))
+         (setq in-word nil))))
+    n-words))
+
+#+excl
+(defun delimited-string-to-list (string &optional (separator #\space))
+  (excl:delimited-string-to-list string separator))
+
+#-excl
+(defun delimited-string-to-list (sequence &optional (separator #\space))
+"Split a string by a delimitor"
+  (loop
+      with start = 0
+      for end = (position separator sequence :start start)
+      collect (subseq sequence start end)
+      until (null end)
+      do
+    (setf start (1+ end))))
+
+#+excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+  (excl:list-to-delimited-string list separator))
+
+#-excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+  (let ((output (when list (format nil "~A" (car list)))))
+    (dolist (obj (rest list))
+      (setq output (concatenate 'string output
+                               (format nil "~A" separator)
+                               (format nil "~A" obj))))
+    output))
+
+(defun string-invert (str)
+  "Invert case of a string"
+  (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
+           (simple-string str))
+  (let ((up nil) (down nil))
+    (block skip
+      (loop for char of-type character across str do
+           (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
+                 ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
+      (if up (string-downcase str) (string-upcase str)))))
+
+(defun add-sql-quotes (s)
+  (substitute-string-for-char s #\' "''"))
+
+(defun escape-backslashes (s)
+  (substitute-string-for-char s #\\ "\\\\"))
+
+(defun substitute-string-for-char (procstr match-char subst-str) 
+"Substitutes a string for a single matching character of a string"
+  (let ((pos (position match-char procstr)))
+    (if pos
+       (concatenate 'string
+         (subseq procstr 0 pos) subst-str
+         (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
+      procstr)))
+
+(defun string-substitute (string substring replacement-string)
+  "String substitute by Larry Hunter. Obtained from Google"
+  (let ((substring-length (length substring))
+       (last-end 0)
+       (new-string ""))
+    (do ((next-start
+         (search substring string)
+         (search substring string :start2 last-end)))
+       ((null next-start)
+        (concatenate 'string new-string (subseq string last-end)))
+      (setq new-string
+       (concatenate 'string
+         new-string
+         (subseq string last-end next-start)
+         replacement-string))
+      (setq last-end (+ next-start substring-length)))))
+
+
+(defun string-trim-last-character (s)
+"Return the string less the last character"
+  (subseq s 0 (1- (length s))))
+
+(defun string-hash (str &optional (bitmask 65535))
+  (let ((hash 0))
+    (declare (fixnum hash)
+            (simple-string str))
+    (dotimes (i (length str))
+      (declare (fixnum i))
+      (setq hash (+ hash (char-code (char str i)))))
+    (logand hash bitmask)))
+
+(defun string-not-null? (str)
+  (and str (not (zerop (length str)))))
+  
+(defun whitespace? (c) 
+  (declare (character c))
+  (declare (optimize (speed 3) (safety 0)))
+  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
+
+(defun not-whitespace? (c)
+  (not (whitespace? c)))
+
+(defun string-ws? (str)
+  "Return t if string is all whitespace"
+  (when (stringp str)
+    (null (find-if #'not-whitespace? str))))
+
+
+;;; Output
+
+(unless (boundp '+indent-vector+)
+  (defconstant +indent-vector+ 
+      (make-array 15 :fill-pointer nil :adjustable nil
+                 :initial-contents
+                 '("" 
+                   "  "
+                   "    "
+                   "      "
+                   "        "
+                   "          "
+                   "            "
+                   "              "
+                   "                "
+                   "                  "
+                   "                    "
+                   "                      "
+                   "                        "
+                   "                          "
+                   "                            "))))
+
+(defmacro indent-spaces (n &optional stream)
+  "Indent n*2 spaces to output stream"
+  (let ((st (gensym)))
+    `(let ((,st ,stream))
+       (unless ,st
+        (setq ,st *standard-output*))
+       (when (plusp ,n)
+        (if (< ,n 10)
+            (princ (aref +indent-vector+ ,n) ,st)
+          (dotimes (i ,n)
+            (declare (fixnum i))
+            (format ,st "  ")))))))
+  
+(defun print-list (l &optional (output *standard-output*))
+"Print a list to a stream"
+  (if (consp l)
+    (progn
+      (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
+      t)
+    nil))
+
+(defun print-rows (rows &optional (ostrm *standard-output*))
+"Print a list of list rows to a stream"  
+  (dolist (r rows)
+    (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
+    (terpri ostrm)))
+
+
+;;; Symbol functions
+
+(defmacro concat-symbol (&rest args)
+  `(intern (concatenate 'string ,@args)))
+
+(defmacro concat-symbol-pkg (pkg &rest args)
+  `(intern (concatenate 'string ,@args) ,pkg))
+
+
+;;; IO
+
+
+(defstruct buf
+  vec (start -1) (used -1) (new -1) (end -1))
+
+(defun bref (buf n)
+  (svref (buf-vec buf)
+         (mod n (length (buf-vec buf)))))
+
+(defun (setf bref) (val buf n)
+  (setf (svref (buf-vec buf)
+               (mod n (length (buf-vec buf))))
+        val))
+
+(defun new-buf (len)
+  (make-buf :vec (make-array len)))
+
+(defun buf-insert (x b)
+  (setf (bref b (incf (buf-end b))) x))
+
+(defun buf-pop (b)
+  (prog1 
+    (bref b (incf (buf-start b)))
+    (setf (buf-used b) (buf-start b)
+          (buf-new  b) (buf-end   b))))
+
+(defun buf-next (b)
+  (when (< (buf-used b) (buf-new b))
+    (bref b (incf (buf-used b)))))
+
+(defun buf-reset (b)
+  (setf (buf-used b) (buf-start b)
+        (buf-new  b) (buf-end   b)))
+
+(defun buf-clear (b)
+  (setf (buf-start b) -1 (buf-used  b) -1
+        (buf-new   b) -1 (buf-end   b) -1))
+
+(defun buf-flush (b str)
+  (do ((i (1+ (buf-used b)) (1+ i)))
+      ((> i (buf-end b)))
+    (princ (bref b i) str)))
+
+
+(defun file-subst (old new file1 file2)
+  (with-open-file (in file1 :direction :input)
+     (with-open-file (out file2 :direction :output
+                                :if-exists :supersede)
+       (stream-subst old new in out))))
+
+(defun stream-subst (old new in out)
+  (declare (string old new))
+  (let* ((pos 0)
+         (len (length old))
+         (buf (new-buf len))
+         (from-buf nil))
+    (declare (fixnum pos len))
+    (do ((c (read-char in nil :eof)
+            (or (setf from-buf (buf-next buf))
+                (read-char in nil :eof))))
+        ((eql c :eof))
+      (declare (character c))
+      (cond ((char= c (char old pos))
+             (incf pos)
+             (cond ((= pos len)            ; 3
+                    (princ new out)
+                    (setf pos 0)
+                    (buf-clear buf))
+                   ((not from-buf)         ; 2
+                    (buf-insert c buf))))
+            ((zerop pos)                   ; 1
+             (princ c out)
+             (when from-buf
+               (buf-pop buf)
+               (buf-reset buf)))
+            (t                             ; 4
+             (unless from-buf
+               (buf-insert c buf))
+             (princ (buf-pop buf) out)
+             (buf-reset buf)
+             (setf pos 0))))
+    (buf-flush buf out)))
+
+
+;;; Tree Functions
+
+(defun remove-tree-if (pred tree)
+  "Strip from tree of atoms that satistify predicate"
+  (if (atom tree)
+      (unless (funcall pred tree)
+       tree)
+    (let ((car-strip (remove-tree-if pred (car tree)))
+         (cdr-strip (remove-tree-if pred (cdr tree))))
+      (cond
+       ((and car-strip (atom (cadr tree)) (null cdr-strip))
+       (list car-strip))
+       ((and car-strip cdr-strip)
+       (cons car-strip cdr-strip))
+       (car-strip
+       car-strip)
+       (cdr-strip
+       cdr-strip)))))
+
+(defun find-tree (sym tree)
+  "Finds an atom as a car in tree and returns cdr tree at that positions"
+  (if (or (null tree) (atom tree))
+      nil
+    (if (eql sym (car tree))
+       (cdr tree)
+      (aif (find-tree sym (car tree))
+         it
+       (aif (find-tree sym (cdr tree))
+           it
+         nil)))))
+
+;;; Files
+
+(defun print-file-contents (file &optional (strm *standard-output*))
+  "Opens a reads a file. Returns the contents as a single string"
+  (when (probe-file file)
+    (with-open-file (in file :direction :input)
+                   (do ((line (read-line in nil 'eof) 
+                              (read-line in nil 'eof)))
+                       ((eql line 'eof))
+                     (format strm "~A~%" line)))))
+
+(defun read-file-to-string (file)
+  "Opens a reads a file. Returns the contents as a single string"
+  (with-output-to-string (out)
+    (with-open-file (in file :direction :input)
+      (do ((line (read-line in nil 'eof) 
+                (read-line in nil 'eof)))
+         ((eql line 'eof))
+       (format out "~A~%" line)))))
+
+(defun read-file-to-strings (file)
+  "Opens a reads a file. Returns the contents as a list of strings"
+  (let ((lines '()))
+    (with-open-file (in file :direction :input)
+      (do ((line (read-line in nil 'eof) 
+                (read-line in nil 'eof)))
+         ((eql line 'eof))
+       (push line lines)))
+    (nreverse lines)))
+
+
+;; Generalized equal system
+  
+(defun generalized-equal (obj1 obj2)
+  (if (not (equal (type-of obj1) (type-of obj2)))
+      (progn
+       (terpri)
+       (describe obj1)
+       (describe obj2)
+       nil)
+    (typecase obj1
+      (double-float
+       (let ((diff (abs (/ (- obj1 obj2) obj1))))
+        (if (> diff (* 10 double-float-epsilon))
+            nil
+          t)))
+      (complex
+       (and (generalized-equal (realpart obj1) (realpart obj2))
+           (generalized-equal (imagpart obj1) (imagpart obj2))))
+      (structure
+       (generalized-equal-fielded-object obj1 obj2))
+      (standard-object
+       (generalized-equal-fielded-object obj1 obj2))
+      (hash-table
+       (generalized-equal-hash-table obj1 obj2)
+       )
+      (function
+       (generalized-equal-function obj1 obj2))
+      (string
+       (string= obj1 obj2))
+      (array
+       (generalized-equal-array obj1 obj2))
+      (t
+       (equal obj1 obj2)))))
+
+
+(defun generalized-equal-function (obj1 obj2)
+  (string= (function-to-string obj1) (function-to-string obj2)))
+
+(defun generalized-equal-array (obj1 obj2)
+  (block test
+    (when (not (= (array-total-size obj1) (array-total-size obj2)))
+      (return-from test nil))
+    (dotimes (i (array-total-size obj1))
+      (unless (generalized-equal (aref obj1 i) (aref obj2 i))
+       (return-from test nil)))
+    (return-from test t)))
+
+(defun generalized-equal-hash-table (obj1 obj2)
+  (block test
+    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
+      (return-from test nil))
+    (maphash
+     #'(lambda (k v)
+        (multiple-value-bind (value found) (gethash k obj2)
+          (unless (and found (generalized-equal v value))
+            (return-from test nil))))
+     obj1)
+    (return-from test t)))
+
+(defun generalized-equal-fielded-object (obj1 obj2)
+  (block test
+    (when (not (equal (class-of obj1) (class-of obj2)))
+      (return-from test nil))
+    (dolist (field (class-slot-names (class-name (class-of obj1))))
+      (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
+       (return-from test nil)))
+    (return-from test t)))
+
+#+(or allegro lispworks)
+(defun class-slot-names (class-name)
+  "Given a CLASS-NAME, returns a list of the slots in the class."
+  (mapcar #'clos:slot-definition-name
+         (clos:class-slots (find-class class-name))))
+
+#-(or allegro lispworks)
+(defun class-slot-names (class-name)
+  (warn "class-slot-names not supported on this platform"))
+
+
+(defun function-to-string (obj)
+  "Returns the lambda code for a function. Relies on
+Allegro implementation-dependent features."
+  (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
+    (declare (ignore closurep))
+    (if lambda
+         (format nil "#'~s" lambda)
+      (if name
+         (format nil "#'~s" name)
+       (progn
+         (print obj)
+         (break))))))
+
+
+;;; Formatting functions
+
+(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
+  (multiple-value-bind (sec min hr dy mn yr wkday)
+    (decode-universal-time
+     (encode-universal-time s m hour day month year))
+    (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
+                  "Friday" "Saturday" "Sunday")
+                wkday)
+           (elt '("January" "February" "March" "April" "May" "June"
+                  "July" "August" "September" "October" "November"
+                  "December")
+                (1- mn))
+           (format nil "~A" dy) (format nil "~A" yr)
+           (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
+
+
+(defun date-string (ut)
+  (if (typep ut 'integer)
+      (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
+         (decode-universal-time ut)
+       (declare (ignore daylight-p zone))
+       (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~
+~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~
+~2,'0d:~2,'0d:~2,'0d" 
+               dow
+               day
+               (1- mon)
+               year
+               hr min sec))))
+

diff --git a/kmrcl.asd b/kmrcl.asd
new file mode 100644 (file)
index 0000000..04124bc
--- /dev/null
+++ b/kmrcl.asd
@@ -0,0 +1,39 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          kmrcl.asd
+;;;; Purpose:       ASDF system definition for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: kmrcl.asd,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+#+allegro (require :pxml)
+#+allegro (require :aserve)
+
+(in-package :asdf)
+
+(defsystem :kmrcl
+    :components 
+    ((:file "package")
+     (:file "genutils" :depends-on ("package"))
+     (:file "buff-input" :depends-on ("genutils"))
+     (:file "telnet-server" :depends-on ("genutils"))
+     (:file "pipes" :depends-on ("package"))
+     (:file "random" :depends-on ("package"))
+     (:file "cl-symbols" :depends-on ("package"))
+     #+allegro (:file "attrib-class" :depends-on ("package"))
+     
+     (:file "web-utils" :depends-on ("package"))
+     (:file "xml-utils" :depends-on ("package"))
+     #+(or allegro lispworks) (:file "ml-class" :depends-on ("package"))
+     #+(or allegro aserve) (:file "web-utils-aserve" :depends-on ("package"))
+     ))
+

diff --git a/ml-class.lisp b/ml-class.lisp
new file mode 100644 (file)
index 0000000..cfe2ab7
--- /dev/null
+++ b/ml-class.lisp
@@ -0,0 +1,625 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          ml-class.lisp
+;;;; Purpose:       Markup Language Metaclass
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; This metaclass as functions to classes to allow display
+;;;; in Text, HTML, and XML formats. This includes hyperlinking
+;;;; capability and sub-objects.
+;;;;
+;;;; $Id: ml-class.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+ 
+(in-package :webutils)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+
+(defclass ml-class (standard-class)
+  ((title :initarg :title :type string :reader ml-std-title
+         :documentation 
+"Print Title for class")
+   (fields :initarg :fields :reader ml-std-fields
+          :documentation
+"List of field lists for printing. Format is 
+   ((fieldname type optional-formatter) ... )")
+   (subobjects-lists 
+    :initarg :subobjects-lists :reader ml-std-subobjects-lists
+    :documentation 
+"List of fields that contain a list of subobjects objects.")
+   (ref-fields 
+    :initarg :ref-fields :type list :reader ml-std-ref-field
+    :documentation 
+    "List of fields that can be referred to by browsers. 
+Format is ((field-name field-lookup-func other-link-params) ...)")
+   
+   ;;; The remainder of these fields are calculated one time
+   ;;; in finalize-inheritence.
+   (value-func :initform nil :type function :reader ml-std-value-func)
+   (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
+   (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
+   (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
+   (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
+   (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
+   (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
+   (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
+   (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
+   (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
+   (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
+   (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
+   )
+  (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
+  (:documentation "Metaclass for Markup Language classes."))
+
+
+#+allegro
+(defmethod mop:finalize-inheritance :after ((cl ml-class))
+  (init-ml-class cl))
+
+#+lispworks
+(defmethod clos:finalize-inheritance :after ((cl ml-class))
+  (init-ml-class cl))
+
+#+cmu
+(defmethod pcl:finalize-inheritance :after ((cl ml-class))
+  (init-ml-class cl))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+                                       (name (eql :title))
+                                       value)
+  (unless value
+    (error "ml-class title must have a value"))
+  (if (null (cdr value))
+      (list name (car value))
+    (list name `',value)))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+                                       (name (eql :fields))
+                                       value)
+  (unless value
+    (error "ml-class fields must have a value"))
+  (list name `',value))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+                                       (name (eql :ref-fields))
+                                       value)
+  (unless value
+    (error "ml-class ref-fields must have a value"))
+  (list name `',value))
+
+#+lispworks
+(defmethod clos:process-a-class-option ((class ml-class)
+                                       (name (eql :subobjects-lists))
+                                       value)
+  (unless value
+    (error "ml-class subobjects-lists must have a value"))
+  (list name `',value))
+
+;;;; Class initialization function
+      
+(defun init-ml-class (cl)
+    (let ((fmtstr-text "")
+         (fmtstr-html "")
+         (fmtstr-xml "")
+         (fmtstr-text-labels "")
+         (fmtstr-html-labels "")
+         (fmtstr-xml-labels "")
+         (fmtstr-html-ref "")
+         (fmtstr-xml-ref "")
+         (fmtstr-html-ref-labels "")
+         (fmtstr-xml-ref-labels "")
+         (first-field t)
+         (value-func '())
+         (xmlvalue-func '())
+         (classname (class-name cl))
+         (ref-fields (slot-value cl 'ref-fields)))
+      (declare (ignore classname))
+      (dolist (f (slot-value cl 'fields))
+       (let ((name (car f))
+             (namestr (symbol-name (car f)))
+             (namestr-lower (string-downcase (symbol-name (car f))))
+             (type (cadr f))
+             (formatter (caddr f))
+             (value-fmt "~a")
+             (plain-value-func nil)
+             html-str xml-str html-label-str xml-label-str)
+         
+         (when (or (eql type :integer) (eql type :fixnum))
+           (setq value-fmt "~d"))
+         
+         (when (eql type :commainteger)
+           (setq value-fmt "~:d"))
+         
+         (when (eql type :boolean)
+           (setq value-fmt "~a"))
+           
+         (if first-field
+             (setq first-field nil)
+           (progn
+             (gu:string-append fmtstr-text " ")
+             (gu:string-append fmtstr-html " ")
+             (gu:string-append fmtstr-xml " ")
+             (gu:string-append fmtstr-text-labels " ")
+             (gu:string-append fmtstr-html-labels " ")
+             (gu:string-append fmtstr-xml-labels " ")
+             (gu:string-append fmtstr-html-ref " ")
+             (gu:string-append fmtstr-xml-ref " ")
+             (gu:string-append fmtstr-html-ref-labels " ")
+             (gu:string-append fmtstr-xml-ref-labels " ")))
+         
+         (setq html-str value-fmt)
+         (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+         (setq html-label-str (concatenate 'string "<i>" namestr-lower "</i> " value-fmt))
+         (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+         
+         (gu:string-append fmtstr-text value-fmt)
+         (gu:string-append fmtstr-html html-str)
+         (gu:string-append fmtstr-xml xml-str)
+         (gu:string-append fmtstr-text-labels namestr-lower " " value-fmt)
+         (gu:string-append fmtstr-html-labels html-label-str)
+         (gu:string-append fmtstr-xml-labels xml-label-str)
+         
+         (if (find name ref-fields :key #'car)
+           (progn
+             (gu:string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
+             (gu:string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
+             (gu:string-append fmtstr-html-ref-labels "<i>" namestr-lower "</i> <~~a>" value-fmt "</~~a>")
+             (gu:string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
+           (progn
+             (gu:string-append fmtstr-html-ref html-str)
+             (gu:string-append fmtstr-xml-ref xml-str)
+             (gu:string-append fmtstr-html-ref-labels html-label-str)
+             (gu:string-append fmtstr-xml-ref-labels xml-label-str)))
+         
+         (if formatter
+             (setq plain-value-func 
+               (list `(,formatter (,(gu:concat-symbol-pkg 
+                                     :umlisp namestr) x))))
+           (setq plain-value-func 
+             (list `(,(gu:concat-symbol-pkg 
+                       :umlisp namestr) x))))
+         (setq value-func (append value-func plain-value-func))
+         
+         (if (eql type :cdata)
+             (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
+           (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
+         ))
+
+      (setq value-func `(lambda (x) (values ,@value-func)))
+      (setq value-func (compile nil (eval value-func)))
+      (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
+      (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
+
+      (setf (slot-value cl 'fmtstr-text) fmtstr-text)
+      (setf (slot-value cl 'fmtstr-html) fmtstr-html)
+      (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
+      (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
+      (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
+      (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
+      (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
+      (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
+      (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
+      (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
+      (setf (slot-value cl 'value-func) value-func)
+      (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
+    (values))
+
+
+(defun ml-class-fmtstr-text (obj)
+  (slot-value (class-of obj) 'fmtstr-text))
+
+(defun ml-class-fmtstr-html (obj)
+  (slot-value (class-of obj) 'fmtstr-html))
+
+(defun ml-class-fmtstr-xml (obj)
+  (slot-value (class-of obj) 'fmtstr-xml))
+
+(defun ml-class-fmtstr-text-labels (obj)
+  (slot-value (class-of obj) 'fmtstr-text-labels))
+
+(defun ml-class-fmtstr-html-labels (obj)
+  (slot-value (class-of obj) 'fmtstr-html-labels))
+
+(defun ml-class-fmtstr-xml-labels (obj)
+  (slot-value (class-of obj) 'fmtstr-xml-labels))
+
+(defun ml-class-value-func (obj)
+  (slot-value (class-of obj) 'value-func))
+
+(defun ml-class-xmlvalue-func (obj)
+  (slot-value (class-of obj) 'xmlvalue-func))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun ml-class-title (obj)
+  (gu:awhen (slot-value (class-of obj) 'title)
+           (if (consp gu:it)
+               (car gu:it)
+             gu:it))))
+
+(defun ml-class-subobjects-lists (obj)
+  (slot-value (class-of obj) 'subobjects-lists))
+
+(defun ml-class-ref-fields (obj)
+  (slot-value (class-of obj) 'ref-fields))
+
+(defun ml-class-fields (obj)
+  (slot-value (class-of obj) 'fields))
+
+(defun ml-class-fmtstr-html-ref (obj)
+  (slot-value (class-of obj) 'fmtstr-html-ref))
+
+(defun ml-class-fmtstr-xml-ref (obj)
+  (slot-value (class-of obj) 'fmtstr-xml-ref))
+
+(defun ml-class-fmtstr-html-ref-labels (obj)
+  (slot-value (class-of obj) 'fmtstr-html-ref-labels))
+
+(defun ml-class-fmtstr-xml-ref-labels (obj)
+  (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
+
+;;; Class name functions
+
+(defmethod ml-class-stdname ((name string))
+  (string-downcase (subseq name :start 1)))
+  
+(defmethod ml-class-stdname ((cl standard-object))
+  (string-downcase (subseq (class-name (class-of cl)) :start 1)))
+  
+;;;; Generic Print functions
+
+(defparameter *default-textformat* nil)
+(defparameter *default-htmlformat* nil)
+(defparameter *default-htmlrefformat* nil)
+(defparameter *default-xmlformat* nil)
+(defparameter *default-xmlrefformat* nil)
+(defparameter *default-nullformat* nil)
+(defparameter *default-init-format?* nil)
+
+(defun make-format-instance (fmt)
+  (unless *default-init-format?*
+    (setq *default-textformat* (make-instance 'textformat))
+    (setq *default-htmlformat* (make-instance 'htmlformat))
+    (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
+    (setq *default-xmlformat* (make-instance 'xmlformat))
+    (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
+    (setq *default-nullformat* (make-instance 'nullformat))
+    (setq *default-init-format?* t))
+  
+  (case fmt
+      (:text *default-textformat*)
+      (:html *default-htmlformat*)
+      (:htmlref *default-htmlrefformat*)
+      (:xml  *default-xmlformat*)
+      (:xmlref *default-xmlrefformat*)
+      (:null *default-nullformat*)
+      (otherwise *default-textformat*)))
+    
+;;;; Output format classes for print ml-classes
+
+(defclass dataformat ()
+  ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
+   (file-end-str :type string :initarg :file-end-str :reader file-end-str)
+   (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
+   (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
+   (list-start-indent :initarg :list-start-indent :reader list-start-indent)
+   (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
+   (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
+   (list-end-indent :initarg :list-end-indent :reader list-end-indent)
+   (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
+   (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
+   (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
+   (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
+   (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
+   (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
+   (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
+   (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
+   (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
+   (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
+   (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
+   (link-ref :initarg :link-ref :reader link-ref))
+  (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
+                    :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
+                    :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
+                    :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
+                    :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
+                    :obj-data-value-func nil :link-ref nil)
+  (:documentation "Parent for all dataformat objects"))
+
+(defclass binaryformat (dataformat)
+  ())
+
+(defclass nullformat (dataformat)
+  ())
+
+(defun text-list-start-value-func (obj nitems)
+  (values (ml-class-title obj) nitems))
+
+(defclass textformat (dataformat) 
+  ()   
+  (:default-initargs :list-start-fmtstr "~a~P:~%"
+    :list-start-value-func #'text-list-start-value-func
+    :list-start-indent t
+    :obj-data-indent t
+    :obj-data-fmtstr #'ml-class-fmtstr-text
+    :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels
+    :obj-data-end-fmtstr "~%"
+    :obj-data-value-func #'ml-class-value-func))
+
+(defclass htmlformat (textformat) 
+  ()
+  (:default-initargs :file-start-str "<html><body>~%"
+    :file-end-str "</body><html>~%"
+    :list-start-indent t
+    :list-start-fmtstr "<p><b>~a~P:</b></p><ul>~%"
+    :list-start-value-func #'text-list-start-value-func
+    :list-end-fmtstr "</ul>~%"
+    :list-end-indent t
+    :list-end-value-func #'identity
+    :obj-start-indent t
+    :obj-start-fmtstr "<li>"
+    :obj-start-value-func #'identity
+    :obj-end-indent  t
+    :obj-end-fmtstr  "</li>~%"
+    :obj-end-value-func #'identity
+    :obj-data-indent t
+    :obj-data-fmtstr #'ml-class-fmtstr-html-labels
+    :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels
+    :obj-data-value-func #'ml-class-value-func))
+
+(defclass htmlrefformat (htmlformat)
+  ()
+  (:default-initargs :link-ref (make-instance 'html-link-ref)))
+
+(defun class-name-of (obj)
+  (string-downcase (class-name (class-of obj))))
+
+(defun xmlformat-list-end-value-func (x)
+  (format nil "~alist" (string-downcase (class-name (class-of x)))))
+
+(defun xmlformat-list-start-value-func (x nitems) 
+  (values (format nil "~alist" (string-downcase (class-name (class-of x)))) (ml-class-title x) nitems))
+
+(defclass xmlformat (textformat) 
+  ()
+  (:default-initargs :file-start-str "" ; (gu:std-xml-header)
+    :list-start-indent  t
+    :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
+    :list-start-value-func #'xmlformat-list-start-value-func
+    :list-end-indent  t
+    :list-end-fmtstr "</~a>~%"
+    :list-end-value-func #'xmlformat-list-end-value-func
+    :obj-start-fmtstr "<~a>"
+    :obj-start-value-func #'class-name-of
+    :obj-start-indent t
+    :obj-end-fmtstr "</~a>~%"
+    :obj-end-value-func #'class-name-of
+    :obj-end-indent nil
+    :obj-data-indent nil
+    :obj-data-fmtstr #'ml-class-fmtstr-xml
+    :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels
+    :obj-data-value-func #'ml-class-xmlvalue-func))
+
+(defclass xmlrefformat (xmlformat)
+  ()
+  (:default-initargs :link-ref (make-instance 'xml-link-ref)))
+
+(defclass link-ref ()
+  ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
+   (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
+   (page-name :type string :initarg :page-name :accessor page-name)
+   (href-head :type string :initarg :href-head :accessor href-head)
+   (href-end :type string :initarg :href-end :accessor href-end)
+   (ampersand :type string :initarg :ampersand :accessor ampersand))
+  (:default-initargs :fmtstr nil 
+    :fmtstr-labels nil 
+    :page-name "disp-func1" 
+    :href-head nil :href-end nil :ampersand nil)
+  (:documentation "Formatting for a linked reference"))
+
+(defclass html-link-ref (link-ref)
+  ()
+  (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref  
+    :fmtstr-labels #'ml-class-fmtstr-html-ref-labels
+    :href-head "a href=" 
+    :href-end "a" 
+    :ampersand "&"))
+
+(defclass xml-link-ref (link-ref)
+  ()
+  (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref 
+    :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels
+    :href-head "xmllink xlink:type=\"simple\" xlink:href=" 
+    :href-end "xmllink" 
+    :ampersand "&amp;"))
+
+
+;;; File Start and Ends
+
+(defmethod fmt-file-start ((fmt dataformat) (s stream)))
+
+(defmethod fmt-file-start ((fmt textformat) (s stream))
+  (gu:aif (file-start-str fmt)
+      (format s gu::it)))
+
+(defmethod fmt-file-end ((fmt textformat) (s stream))
+  (gu:aif (file-end-str fmt)
+         (format s gu::it)))
+
+;;; List Start and Ends
+
+(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
+  (if (list-start-indent fmt)
+      (gu:indent-spaces indent s))
+  (gu:aif (list-start-fmtstr fmt)
+         (apply #'format s gu::it
+                (multiple-value-list
+                 (funcall (list-start-value-func fmt) x num-items)))))
+
+(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
+  (declare (ignore num-items))
+  (if (list-end-indent fmt)
+      (gu:indent-spaces indent s))
+  (gu:aif (list-end-fmtstr fmt)
+         (apply #'format s gu::it
+                (multiple-value-list
+                 (funcall (list-end-value-func fmt) x)))))
+
+;;; Object Start and Ends
+
+(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
+  (if (obj-start-indent fmt)
+      (gu:indent-spaces indent s))
+  (gu:aif (obj-start-fmtstr fmt)
+         (apply #'format s gu::it
+                (multiple-value-list
+                 (funcall (obj-start-value-func fmt) x)))))
+
+(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
+  (if (obj-end-indent fmt)
+      (gu:indent-spaces indent s))
+  (gu:aif (obj-end-fmtstr fmt)
+         (apply #'format s gu::it
+                (multiple-value-list
+                 (funcall (obj-end-value-func fmt) x)))))
+  
+;;; Object Data 
+
+(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
+  (declare (ignore obj fieldname))
+  (format nil "~a\"~a?func=~a~akey=~a~a\"" 
+         (href-head ref) (make-url (page-name ref)) fieldfunc 
+         (ampersand ref) fieldvalue
+         (if refvars
+             (let ((varstr ""))
+               (dolist (var refvars)
+                 (gu:string-append varstr (format nil "~a~a=~a" 
+                                               (ampersand ref) (car var) (cadr var))))
+               varstr)
+           "")))
+
+(defmethod make-link-end (obj (ref link-ref) fieldname)
+  (declare (ignore obj fieldname))
+  (format nil "~a" (href-end ref))
+  )
+
+(defmethod fmt-obj-data (x (fmt textformat) s
+                        &optional (indent 0) (label nil) (refvars nil))
+  (if (obj-data-indent fmt)
+      (gu:indent-spaces indent s))
+  (if (link-ref fmt)
+      (fmt-obj-data-with-ref x fmt s label refvars)
+    (fmt-obj-data-plain x fmt s label))
+  (gu:aif (obj-data-end-fmtstr fmt)
+       (format s gu::it)))
+
+(defmethod fmt-obj-data-plain (x (fmt textformat) s label)
+  (if label
+      (apply #'format s
+            (funcall (obj-data-fmtstr-labels fmt) x)
+            (multiple-value-list 
+             (funcall (funcall (obj-data-value-func fmt) x) x)))
+    (apply #'format s (funcall (obj-data-fmtstr fmt) x)
+          (multiple-value-list
+           (funcall (funcall (obj-data-value-func fmt) x) x)))))
+
+(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
+  (let ((refstr (make-ref-data-str x fmt label))
+       (refvalues nil)
+       (field-values 
+        (multiple-value-list
+         (funcall (funcall (obj-data-value-func fmt) x) x))))
+    
+    ;; make list of reference link fields for printing to refstr template
+    (dolist (field (ml-class-ref-fields x))
+      (let ((link-start 
+            (make-link-start x (link-ref fmt) (car field) (cadr field)
+                             (nth (position (car field) (ml-class-fields x) :key #'car) field-values)  
+                             (append (caddr field) refvars)))
+           (link-end (make-link-end x (link-ref fmt) (car field))))
+       (push link-start refvalues)
+       (push link-end refvalues)))
+    (setq refvalues (nreverse refvalues))
+    
+    (apply #'format s refstr refvalues)))
+  
+(defmethod obj-data (x)
+  "Returns the objects data as a string. Used by common-graphics outline function"
+  (let ((fmt (make-format-instance :text)))
+    (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
+          (multiple-value-list 
+           (funcall (funcall (obj-data-value-func fmt) x) x)))))
+
+(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
+  "Return fmt string for that contains ~a slots for reference link start and end"
+  (unless (link-ref fmt)
+    (error "fmt does not contain a link-ref"))
+  (let ((refstr 
+        (if label
+            (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
+                   (multiple-value-list
+                     (funcall (funcall (obj-data-value-func fmt) x) x)))
+          (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
+                 (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
+    refstr))
+  
+;;; Display method for objects
+
+
+(defmethod load-all-subobjects (objs)
+  "Load all subobjects if they have not already been loaded."
+  (when objs
+    (let ((objlist (gu:mklist objs)))
+      (dolist (obj objlist)
+        (gu:awhen (ml-class-subobjects-lists obj)  ;; access list of functions
+          (dolist (child-obj gu::it)   ;; for each child function
+            (gu:awhen (funcall (car child-obj) obj)
+              (load-all-subobjects gu:it))))))
+    objs))
+
+(defmethod output-ml-class (objs (fmt dataformat) (strm stream) 
+                           &optional (label nil) (english-only-function nil)
+                                     (indent 0) (subobjects nil) (refvars nil))
+  "Display a single or list of ml-class instances and their subobjects"
+  (when objs
+    (setq objs (gu:mklist objs))
+    (let ((nobjs (length objs)))
+      (fmt-list-start (car objs) fmt strm indent nobjs)
+      (dolist (obj objs)
+        (unless (and english-only-function (not (funcall english-only-function obj)))
+          (fmt-obj-start obj fmt strm indent)
+          (fmt-obj-data obj fmt strm (1+ indent) label refvars)
+          (if subobjects
+              (gu:awhen (ml-class-subobjects-lists obj)  ;; access list of functions
+                        (dolist (child-obj gu::it)   ;; for each child function
+                          (gu:awhen (funcall (car child-obj) obj) ;; access set of child objects
+                                    (output-ml-class gu::it fmt strm label 
+                                                     english-only-function
+                                                     (1+ indent) subobjects refvars)))))
+          (fmt-obj-end obj fmt strm indent)))
+      (fmt-list-end (car objs) fmt strm indent nobjs))
+    t))
+
+(defun display-ml-class (objs &key (os *standard-output*) (format :text)
+                               (label nil) (english-only-function nil) (subobjects nil)
+                               (file-wrapper t) (refvars nil))
+  "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class"
+  (let ((fmt (make-format-instance format)))
+    (if file-wrapper
+       (fmt-file-start fmt os))
+    (when objs
+      (output-ml-class objs fmt os label english-only-function 0 subobjects refvars))
+    (if file-wrapper
+       (fmt-file-end fmt os)))
+  objs)

diff --git a/package.lisp b/package.lisp
new file mode 100644 (file)
index 0000000..fb96460
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,159 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Package definition for kmrcl package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: package.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(in-package :cl-user)
+
+(defpackage #:kmrcl
+  (:nicknames :k)
+  (:use :common-lisp
+       #+(or aserve allegro) :net.html.generator 
+       #+(or aserve allegro) :net.aserve
+       #+allegro :net.xml.parser
+       )
+  (:export #:bind-if
+          #:bind-when
+          #:aif
+         #:awhen
+         #:awhile
+         #:aand
+         #:acond
+         #:alambda
+         #:it
+         #:mac
+         #:show
+         #:show-variables
+         #:show-functions
+         #:ensure-integer
+         #:mklist
+         #:filter
+         #:memo-proc
+         #:memoize
+         #:defun-memo
+         #:_f
+         #:compose
+         #:until
+         #:while
+         #:for
+         #:mapappend
+         #:mapcar-append-string
+         #:mapcar2-append-string
+         #:delimited-string-to-list
+         #:list-to-delimited-string
+         #:string-append
+         #:count-string-words
+         #:substitute-string-for-char
+         #:string-trim-last-character
+         #:string-hash
+         #:string-not-null?
+         #:whitespace?
+         #:not-whitespace?
+         #:string-ws?
+         #:string-invert
+         #:indent-spaces
+         #:print-list
+         #:print-rows
+         #:concat-symbol
+         #:concat-symbol-pkg
+         #:file-subst
+         #:stream-subst
+         #:remove-tree-if
+         #:find-tree
+         #:print-file-contents
+         #:read-file-to-string
+         #:read-file-to-strings
+         #:add-sql-quotes
+         #:escape-backslashes
+         #:remove-keyword
+         #:remove-keywords
+         #:in
+         #:mean
+         #:with-gensyms
+         
+         ;; From attrib-class.lisp
+         #:attributes-class
+         #:slot-attribute
+
+         #:generalized-equal
+         
+         ;; From buffered input
+         
+         #:make-fields-buffer
+         #:read-buffered-fields
+
+         #:pretty-date
+         #:date-string
+
+         ;; From random.lisp
+         #:seed-random-generator
+         #:random-choice
+
+
+         ;; From pipes.lisp
+         #:+empty-pipe+
+         #:make-pipe
+         #:pipe-tail
+         #:pipe-head
+         #:pipe-elt
+         #:enumerate
+         #:pipe-display
+         #:pipe-force
+         #:pipe-filter
+         #:pipe-map
+         #:pipe-map-filtering
+         #:pipe-append
+         #:pipe-mappend
+         #:pipe-mappend-filtering
+
+         ;; From telnet-server.lisp
+         #:start-telnet-server   
+
+         ;; From web-utils
+         #:std-xml-header
+         #:xml-cdata
+
+         ;; From web-utils-allegro
+         #:cgi-var
+         #:print-http
+         #:princ-http
+         #:base-url!
+         #:make-url
+         #:with-tag
+         #:with-tag-attribute
+         #:princ-http-with-color
+         #:princ-http-with-size
+         #:with-link
+         #:home-link
+         #:head
+         #:with-xml-page
+         #:with-trans-page
+         #:wrap-with-xml
+         #:parse-xml-no-ws
+         #:positions-xml-tag-contents
+         #:xml-tag-contents
+         #:encode-query
+
+         ;; From ml-class.lisp
+         #:ml-class
+         #:ml-class-title
+         #:load-all-subobjects
+         #:display-ml-class
+         ))
+
+
+

diff --git a/pipes.lisp b/pipes.lisp
new file mode 100644 (file)
index 0000000..b97ff07
--- /dev/null
+++ b/pipes.lisp
@@ -0,0 +1,228 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          pipes.lisp
+;;;; Purpose:       Pipes based on ideas from Norvig's PAIP book
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: pipes.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defmacro make-pipe (head tail)
+  "create a pipe by eval'ing head and delaying tail."
+  `(cons ,head #'(lambda () ,tail)))
+
+(defun pipe-tail (pipe)
+  "return tail of pipe or list, and destructively update 
+   the tail if it is a function."
+  ;; This assumes that pipes will never contain functions as values...
+  (if (functionp (rest pipe))
+    (setf (rest pipe) (funcall (rest pipe)))
+    (rest pipe)))
+
+(defun pipe-head (pipe) (first pipe))
+
+(defun pipe-elt (pipe i)
+  "ith element of pipe, 0 based."
+  (if (= i 0) (pipe-head pipe)
+     (pipe-elt (pipe-tail pipe) (- i 1))))
+
+(defconstant +empty-pipe+ nil)
+
+(defun enumerate (pipe &key count key (result pipe))
+  "go through all or count elements of pipe,
+   possibly applying the key function. "
+  (if (or (eq pipe +empty-pipe+) (eql count 0))
+    result
+    (progn
+      (unless (null key) (funcall key (pipe-head pipe)))
+      (enumerate (pipe-tail pipe)
+                 :count (if count (1- count))
+                 :key key
+                 :result result))))
+
+(defun pipe-display (pipe &optional count)
+  (enumerate pipe :count count))
+
+(defun pipe-force (pipe)
+  (enumerate pipe))
+
+;;; incorrect version-- as in Norvig.
+;(defun filter-pipe (predicate pipe)
+;  "keep only items in (non-null) pipe satisfying predicate"
+;  (if (funcall predicate (head pipe))
+;    (make-pipe (head pipe) (filter-pipe predicate (tail pipe)))
+;    (pipe-filter predicate (tail pipe))))
+
+
+(defun pipe-filter (predicate pipe)
+  "keep only items in (non-null) pipe satisfying predicate"
+     (if (eq pipe +empty-pipe+)
+      +empty-pipe+
+      (let ((head (pipe-head pipe))
+            (tail (pipe-tail pipe)))
+      (if (funcall predicate head)
+        (make-pipe head (pipe-filter predicate tail))
+        (pipe-filter predicate tail)))))
+               
+
+(defun pipe-map (fn pipe)
+  "Map fn over pipe, delaying all but the first fn call,
+   collecting res<ults"
+  (if (eq pipe +empty-pipe+)
+    +empty-pipe+
+    (make-pipe (funcall fn (pipe-head pipe))
+               (pipe-map fn (pipe-tail pipe)))))
+
+
+(defun pipe-map-filtering (fn pipe &optional filter-test)
+  "Map fn over pipe, delaying all but the first fn call,
+   collecting results"
+  (if (eq pipe +empty-pipe+)
+    +empty-pipe+
+    (let* ((head (pipe-head pipe))
+           (tail (pipe-tail pipe))
+           (result (funcall fn head)))
+      (if (or (and filter-test (funcall filter-test result))
+              result)
+        (make-pipe result (pipe-map-filtering fn tail filter-test))
+        (pipe-map-filtering fn tail filter-test)))))
+      
+      
+(defun pipe-append (pipex pipey)
+  "return a pipe that appends two pipes"
+  (if (eq pipex +empty-pipe+)
+    pipey
+    (make-pipe (pipe-head pipex)
+               (pipe-append (pipe-tail pipex) pipey))))
+
+(defun pipe-mappend (fn pipe)
+  "lazily map fn over pipe, appending results"
+  (if (eq pipe +empty-pipe+)
+    +empty-pipe+
+    (let ((x (funcall fn (pipe-head pipe))))
+      (make-pipe (pipe-head x)
+                 (pipe-append (pipe-tail x)
+                               (pipe-mappend fn (pipe-tail pipe)))))))
+
+(defun pipe-mappend-filtering (fn pipe &optional filter-test)
+  "Map fn over pipe, delaying all but the first fn call,
+   appending results, filtering along the way"
+  (if (eq pipe +empty-pipe+)
+    +empty-pipe+
+    (let* ((head (pipe-head pipe))
+           (tail (pipe-tail pipe))
+           (result (funcall fn head)))
+      (if (or (and filter-test (funcall filter-test result))
+              result)
+        (make-pipe (pipe-head result)
+                   (pipe-append (pipe-tail result)
+                                 (pipe-mappend-filtering fn tail filter-test)))
+        (pipe-mappend-filtering fn tail filter-test)))))
+
+
+
+#||
+;; Applications
+
+(defun integers (&optional (start 0) end)
+  "a pipe of integers from START to END."
+  (if (or (null end) (<= start end))
+    (make-pipe start (integers (+ start 1) end))
+    nil))
+
+(defun fibgen (a b)
+    (make-pipe a (fibgen b (+ a b))))
+
+(defun fibs ()
+  (fibgen 0 1))
+
+
+(defun divisible? (x y) 
+  (zerop (rem x y)))
+
+
+(defun no-sevens ()
+   (pipe-filter #'(lambda (x) (not (divisible? x 7))) (integers)))
+
+
+(defun sieve (stream)
+  (make-pipe
+   (pipe-head stream)
+   (sieve (pipe-filter
+           #'(lambda (x)
+              (not (divisible? x (pipe-head stream))))
+           (pipe-tail stream)))))
+
+(defun primes ()
+  (sieve (integers 2)))
+
+
+;; Pi
+
+(defun scale-pipe (factor pipe)
+  (pipe-map #'(lambda (x) (* x factor)) pipe))
+
+(defun sum-pipe (sum s)
+  (make-pipe sum
+            (sum-pipe (+ sum (pipe-head s))
+                      (pipe-tail s))))
+
+(defun partial-sums (s)
+  (make-pipe (pipe-head s) (sum-pipe 0 s)))
+
+(defun pi-summands (n)
+  (make-pipe (/ 1d0 n)
+            (pipe-map #'- (pi-summands (+ n 2)))))
+
+(defun pi-stream ()
+   (scale-pipe 4d0 (partial-sums (pi-summands 1))))
+
+(defun square (x)
+  (* x x))
+
+(defun euler-transform (s)
+      (let ((s0 (pipe-elt s 0))
+           (s1 (pipe-elt s 1))    
+           (s2 (pipe-elt s 2)))
+       (if (and s0 s1 s2)
+           (if (eql s1 s2)     ;;; series has converged 
+               +empty-pipe+
+             (make-pipe (- s2 (/ (square (- s2 s1))
+                                 (+ s0 (* -2 s1) s2)))
+                        (euler-transform (pipe-tail s))))
+         +empty-pipe+)))
+  
+
+(defun ln2-summands (n)
+  (pipe-map (/ 1d0 n)
+           (pipe-map #'- (ln2-summands (1+ n)))))
+
+(defun ln2-stream ()
+  (partial-sums (ln2-summands 1)))
+
+(defun make-tableau (transform s)
+  (make-pipe s
+            (make-tableau transform
+                          (funcall transform s))))
+
+(defun accelerated-sequence (transform s)
+  (pipe-map #'pipe-head
+           (make-tableau transform s)))
+
+
+ (pipe-display (pi-stream) 10)
+ (pipe-display (euler-transform (pi-stream)) 10)
+ (pipe-display (accelerated-sequence #'euler-transform (pi-stream)) 10)
+
+||#
+

diff --git a/random.lisp b/random.lisp
new file mode 100644 (file)
index 0000000..cf173fc
--- /dev/null
+++ b/random.lisp
@@ -0,0 +1,46 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          random.lisp
+;;;; Purpose:       Random number functions for GENUTILS package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: random.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defun seed-random-generator ()
+  "Evaluate a random number of items"
+  (let ((randfile (make-pathname 
+                  :directory '(:absolute "dev") 
+                  :name "urandom")))
+    (setf *random-state* (make-random-state t))
+    (if (probe-file randfile)
+       (with-open-file
+           (rfs randfile :element-type 'unsigned-byte)
+         (let* 
+             ;; ((seed (char-code (read-char rfs))))
+             ((seed (read-byte rfs)))
+           ;;(format t "Randomizing!~%")
+           (loop
+               for item from 1 to seed
+               do (loop
+                      for it from 0 to (+ (read-byte rfs) 5)
+                      do (random 65536))))))))
+
+
+(defmacro random-choice (&rest exprs)
+  `(case (random ,(length exprs))
+     ,@(let ((key -1))
+         (mapcar #'(lambda (expr)
+                     `(,(incf key) ,expr))
+                 exprs))))
+

diff --git a/telnet-server.lisp b/telnet-server.lisp
new file mode 100644 (file)
index 0000000..c285f0e
--- /dev/null
+++ b/telnet-server.lisp
@@ -0,0 +1,98 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          telnet-server.lisp
+;;;; Purpose:       A telnet server
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: telnet-server.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Genutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :genutils)
+
+(defvar *default-telnet-server-port* 4000)
+
+#+allegro
+(defun start-telnet-server (&optional (port *default-telnet-server-port*))
+  (let ((passive (socket:make-socket :connect :passive
+                                    :local-host "127.1"
+                                    :local-port port
+                                    :reuse-address t)))
+    (mp:process-run-function
+     "telnet-listener"
+     #'(lambda (pass)
+        (let ((count 0))
+          (loop
+            (let ((con (socket:accept-connection pass)))
+              (mp:process-run-function
+               (format nil "tel~d" (incf count))
+               #'(lambda (con)
+                   (unwind-protect
+                       (tpl::start-interactive-top-level
+                        con
+                        #'tpl::top-level-read-eval-print-loop
+                        nil)
+                     (ignore-errors (close con :abort t))))
+               con)))))
+     passive)))
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "comm"))
+
+#+lispworks
+(defun sts2  (&optional (port *default-telnet-server-port*))
+  (comm:start-up-server :service port :function 'comm::make-stream-and-run-listener))
+
+#+lispworks
+(defun make-telnet-stream (handle)
+  (let ((stream (make-instance 'comm:socket-stream
+                 :socket handle
+                 :direction :io
+                 :element-type
+                 'base-char))) 
+    (mp:process-run-function 
+     (format nil "telnet-session ~D" handle)
+     '()
+     'telnet-on-stream stream)))
+
+(defun read-telnet-line (stream)
+  (string-right-trim '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))
+
+(defun print-prompt (stream)
+  (format stream "~&~A> " (package-name *package*))
+  (force-output stream))
+
+(defvar *telnet-password* "ksec")
+
+(defun telnet-on-stream (stream)
+  (unwind-protect
+      (progn
+       (let ((password (read-telnet-line stream))) 
+         (unless (and (stringp password)
+                      (string= password *telnet-password*))
+           (return-from telnet-on-stream)))
+       (print-prompt stream)
+       (loop for line = (read-telnet-line stream)
+           while line
+           do
+             (ignore-errors 
+              (format stream "~S" (eval (read-from-string line))))
+             (force-output stream)
+             (print-prompt stream)))
+    (close stream)))
+
+#+lispworks
+(defun start-telnet-server (&optional (port *default-telnet-server-port*))
+  (comm:start-up-server :service port
+                       :process-name (format nil "telnet-~d" port)
+                       :function 'gu::make-telnet-stream))
+
+

diff --git a/web-utils-aserve.lisp b/web-utils-aserve.lisp
new file mode 100644 (file)
index 0000000..92a89bd
--- /dev/null
+++ b/web-utils-aserve.lisp
@@ -0,0 +1,135 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          web-utils-aserve.lisp
+;;;; Purpose:       Web utilities based on aserve functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: web-utils-aserve.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+
+
+(in-package :webutils)
+(declaim (optimize (speed 3) (safety 1)))
+
+
+;;; AllegroServe interaction functions
+
+(defun cgi-var (var req)
+  "Look CGI variable in AllegroServe association list"
+  (cdr (assoc var (net.aserve:request-query req) :test #'equal)))
+
+(defun princ-http (s)
+  (princ s *html-stream*))
+
+(defun print-http (s)
+  (format *html-stream* "~a~%" s))
+
+
+;;; Tag functions
+
+(defmacro with-tag (tag &rest body)
+  "Outputs to http tag and executes body"
+  `(prog1
+       (progn
+        (princ-http (format nil "<~a>" ,tag))
+        ,@body)
+     (princ-http (format nil "</~a>" ,tag))))
+  
+(defmacro with-tag-attribute (tag attribute &rest body)
+  "Outputs to http tag + attribute and executes body"
+  `(prog1
+       (progn
+        (princ-http (format nil "<~a ~a>" ,tag ,attribute))
+        ,@body)
+     (princ-http (format nil "</~a>" ,tag))))
+  
+(defun princ-http-with-color (text color)
+  (with-tag-attribute "font" (format nil "color=\"~a\"" color)
+                     (princ-http text)))
+
+(defun princ-http-with-size (text size)
+  (with-tag-attribute "font" (format nil "size=\"~a\"" size)
+                     (princ-http text)))
+
+(defmacro with-link ((href xml linktype) &rest body)
+  (declare (ignore linktype))
+;   (format *html-stream* "Return to <cui2 xml:href=\"qstr\">Home</cui2>")
+;   (format *html-stream* "Return to <go xml:link=\"simple\" show=\"replace\" href=\"qstr/\">Home</go>")
+  `(if ,xml
+       (progn
+        (princ-http "<elem xlink:type=\"simple\" xlink:href=\"")
+        (princ-http ,href)
+        (princ-http "\">")
+        ,@body
+        (princ-http "</elem>"))
+     (progn 
+       (princ-http "<a href=\"")
+       (princ-http ,href)
+       (princ-http "\">")
+       ,@body
+       (princ-http "</a>"))))
+
+(defun home-link (&key (xml nil) (vars nil))
+  (princ-http "<font size=\"-1\">Return to ")
+  (with-link ((make-url "index.html" :vars vars) xml "homelink")
+    (princ-http "Browser Home"))
+  (princ-http "</font><p></p>"))
+
+(defun head (title-str)
+  (net.html.generator:html 
+   (:head 
+    "<LINK rel=\"stylesheet\" href=\"http://www.med-info.com/main.css\" type=\"text/css\">"
+    (:title (:princ-safe title-str)))))
+
+
+
+;;; Page wrappers
+
+(defmacro with-xml-page (title &rest body)
+  `(prog1
+       (progn
+        (net.html.generator:html
+         (princ-http (std-xml-header))
+         (princ-http "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">"))
+        (with-tag "pagetitle" (princ-http ,title))
+        ,@body)
+     (princ-http "</pagedata>")))
+
+(defmacro with-trans-page (title &rest body)
+  `(prog1
+       (progn
+         (print-http "<?xml version=\"1.0\" standalone=\"yes\"?>")
+         (print-http "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
+         (print-http " \"http://www.w3c.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
+         (print-http "")
+         (print-http "<html xmlns=\"http://www.w3.org/1999/xhtml\">")
+         (head ,title)
+         (print-http "<body bgcolor=\"#FFFFFF\">")
+         (prog1 
+             ,@body
+           (print-http "</body>")))
+     (print-http "</html>")))
+
+
+;;; URL Encoding
+
+(defun encode-query (query)
+  "Escape [] from net.aserve's query-to-form-urlencoded"
+  (substitute-string-for-char
+   (substitute-string-for-char
+    (substitute-string-for-char 
+     (substitute #\+ #\space query)
+     #\[ "%5B")
+    #\] "%5D")
+   #\" "%22"))
+
+

diff --git a/web-utils.lisp b/web-utils.lisp
new file mode 100644 (file)
index 0000000..c6b9cc8
--- /dev/null
+++ b/web-utils.lisp
@@ -0,0 +1,49 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          web-utils.lisp
+;;;; Purpose:       Basic web utility functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: web-utils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :webutils)
+(declaim (optimize (speed 3) (safety 1)))
+
+
+;;; HTML/XML constants
+
+(defvar *std-xml-header* 
+  (format nil 
+  "<?xml version=\"1.0\" ?>~%<?xml-stylesheet type=\"text/css\" href=\"/umlsclass.css\" ?>~%~%"))
+
+(defun std-xml-header ()
+  *std-xml-header*)
+
+;;; URL Functions
+
+(defvar *base-url* "")
+(defun base-url! (url)
+  (setq *base-url* url))
+
+(defun make-url (page-name &key (base-dir *base-url*) (vars nil))
+  (concatenate 'string base-dir page-name
+              (if vars
+                  (string-trim-last-character
+                   (concatenate 'string "?"
+                                (mapcar-append-string 
+                                 #'(lambda (var) 
+                                     (when (and (car var) (cadr var))
+                                         (concatenate 'string 
+                                           (car var) "=" (cadr var) "&")))
+                                 vars)))
+                "")))
+

diff --git a/xml-utils.lisp b/xml-utils.lisp
new file mode 100644 (file)
index 0000000..bf3b4de
--- /dev/null
+++ b/xml-utils.lisp
@@ -0,0 +1,86 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          xml-utils.lisp
+;;;; Purpose:       XML utilities
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: xml-utils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;;
+;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; Webutils users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package :webutils)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+
+(defun wrap-with-xml (str entity)
+  "Returns string of xml header along with entity tag start/end with str contents"
+  (format nil "<?xml version=\"1.0\" standalone=\"yes\"?>~%~%<~a>~%~a~%</~a>~%" 
+         str entity entity))
+
+
+;;; XML Extraction Functions
+
+#+allegro
+(defun parse-xml-no-ws (str)
+  "Return list structure of XML string with removing whitespace strings"
+  (remove-tree-if #'string-ws? (parse-xml str)))
+
+(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
+  "Returns three values: the start and end positions of contents between
+ the xml tags and the position following the close of the end tag."
+  (let ((done nil)
+       (pos start-xmlstr)
+       (taglen (length tag))
+       (startpos nil)
+       (endpos nil)
+       (nextpos nil))
+    (unless end-xmlstr
+      (setq end-xmlstr (length xmlstr)))
+    (while (not done)
+          (let ((bracketpos (position #\< xmlstr :start pos :end end-xmlstr)))
+            (if bracketpos
+                (let* ((starttag (1+ bracketpos))
+                       (endtag (+ starttag taglen)))
+                  (if (string= tag xmlstr :start2 starttag :end2 endtag)
+                      (let* ((char-after-tag (char xmlstr endtag)))
+                        (declare (character char-after-tag))
+                        (if (or (char= #\> char-after-tag) (char= #\space char-after-tag))
+                            (progn
+                              (if (char= #\> char-after-tag) 
+                                  (setq startpos (1+ endtag))
+                                (setq startpos (1+ (position #\> xmlstr :start (1+ endtag)))))
+                              (setq endpos (search (format nil "</~a>" tag) xmlstr
+                                                   :start2 startpos :end2 end-xmlstr))
+                              (setq done t)
+                              (if (and startpos endpos)
+                                  (progn
+                                    (setq nextpos (+ endpos taglen 3))
+                                    (setq pos nextpos))
+                                (setf startpos nil
+                                      endpos nil)))
+                          (setq pos (1+ endtag))))
+                    (setq pos (1+ starttag)))
+                  (when (> pos end-xmlstr)
+                    (setq done t)))
+              (setq done t))))
+    (values startpos endpos nextpos)))
+
+
+(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
+  "Returns two values: the string between XML start and end tag 
+and position of character following end tag."
+  (multiple-value-bind 
+      (startpos endpos nextpos) 
+      (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
+    (if (and startpos endpos)
+       (values (subseq xmlstr startpos endpos) nextpos)
+      (values nil nil))))
+