+cl-lml (1.1.0-1) unstable; urgency=low
+
+ * Rename .cl files to .lisp
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 30 Sep 2002 04:23:11 -0600
+
cl-lml (1.0.9-2) unstable; urgency=low
* Add missing dependency (closes: 162090)
dh_clean -k
# Add here commands to install the package into debian/lml.
dh_installdirs $(clc-systems) $(clc-lml) $(doc-dir)
- dh_install lml.asd $(shell echo *.cl) $(clc-lml)
+ dh_install lml.asd $(shell echo *.lisp) $(clc-lml)
dh_install $(shell echo doc/*.html) $(doc-dir)
dh_link $(clc-lml)/lml.asd $(clc-systems)/lml.asd
dh_testroot
# dh_installdebconf
dh_installdocs
- dh_installexamples doc/Makefile doc/make.cl $(shell echo doc/*.lml)
+ dh_installexamples doc/Makefile doc/make.lisp $(shell echo doc/*.lml)
# dh_installmenu
# dh_installlogrotate
# dh_installemacsen
#!/bin/bash -e
-dup lml -Uftp.med-info.com -D/home/ftp/lml -C"(cd /opt/apache/htdocs/lml; make install-doc)" $*
+dup lml -Uftp.med-info.com -D/home/ftp/lml -C"(cd /opt/apache/htdocs/lml; make install-doc)" -su $*
all: site
site:
- lisp -init `pwd`/make.cl
+ lisp -init `pwd`/make.lisp
clean:
@rm -f *~ \#*\# .\#* memdump
+++ /dev/null
-#+cmu (setq ext:*gc-verbose* nil)
-
-(require :lml)
-(in-package :lml)
-(let ((cwd (parse-namestring (lml-cwd))))
- (process-dir cwd))
-(lml-quit)
--- /dev/null
+#+cmu (setq ext:*gc-verbose* nil)
+
+(require :lml)
+(in-package :lml)
+(let ((cwd (parse-namestring (lml-cwd))))
+ (process-dir cwd))
+(lml-quit)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: downloads.cl
-;;;; Purpose: Generate downloads page
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Aug 2002
-;;;;
-;;;; $Id: downloads.cl,v 1.7 2002/09/16 03:43:44 kevin Exp $
-;;;;
-;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; LML users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License v2
-;;;; (http://www.gnu.org/licenses/gpl.html)
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :lml)
-
-
-(defvar *ftp-base*)
-(defvar *ftp-url*)
-(defvar *base-name*)
-(defvar *section-indent* 0)
-(defvar *signed* nil)
-
-(defun list-files (files)
- "List files in a directory for downloading"
- ;;files.sort()
- (mapcar #'print-file files))
-
-(defun strip-ftp-base (file)
- (let ((fdir (pathname-directory file))
- (bdir (pathname-directory *ftp-base*)))
- (make-pathname
- :name (pathname-name file)
- :type (pathname-type file)
- :directory
- (when (> (length bdir) (length fdir))
- (append '(:absolute)
- (subseq (length bdir) (length fdir) fdir))))))
-
-(defun print-file (file)
- (let ((size 0)
- (modtime (date-string (file-write-date file)))
- (basename (namestring
- (make-pathname :name (pathname-name file)
- :type (pathname-type file))))
- (ftp-name (strip-ftp-base file))
- (sig-path (concatenate 'string (namestring file) ".asc")))
- (when (plusp (length basename))
- (with-open-file (strm file :direction :input)
- (setq size (round (/ (file-length strm) 1024))))
- (lml-print "<a href=\"~A~A\">~A</a>" *ftp-url* ftp-name basename)
- (lml-print "<span class=\"modtime\">")
- (lml-print " (~A, <b>~:D <span style=\"font-size:90%;\">KB</span></b>)</span>" modtime size)
- (when (probe-file sig-path)
- (setq *signed* t)
- (lml-print " [<a href=\"~A~A.asc\">Signature</a>]" *ftp-url* ftp-name))
- (br))))
-
-(defun display-header (name url)
- (lml-print "<h1>Download</h1>")
- (lml-print "<div class=\"mainbody\">")
- (lml-print "<h3>Browse ~A FTP Site</h3>" name)
- (lml-print "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url))
-
-(defun display-footer ()
- (when *signed*
- (lml-print "<h3>GPG Public Key</h3>")
- (lml-print "Use this <a href=\"https://www.b9.com/key.asc\">key</a> to verify file signtatures"))
- (lml-print "</div>"))
-
-(defun print-sect-title (title)
- (lml-print "<h~D>~A</h~D>" *section-indent* title *section-indent*))
-
-(defun match-base-name? (name)
- (let ((len-base-name (length *base-name*)))
- (when (>= (length name) len-base-name)
- (dotimes (i len-base-name)
- (declare (fixnum i))
- (unless (char= (char *base-name* i)
- (char name i))
- (return-from match-base-name? nil)))))
- t)
-
-(defun filter-against-base (files)
- (let ((filtered '()))
- (dolist (f files)
- (let ((name (pathname-name f)))
- (when (match-base-name? name)
- (push f filtered))))
- (when filtered
- (sort filtered #'(lambda (a b) (when (and a b)
- (string<
- (namestring a)
- (namestring b))))))))
-
-(defun display-one-section (title pat)
- (let ((files (filter-against-base (directory pat))))
- (when files
- (print-sect-title title)
- (lml-print "<div style=\"padding-left: 20pt;\">")
- (list-files files)
- (lml-print"</div>"))))
-
-
-(defun display-sections (sects)
- (when sects
- (let ((title (car sects))
- (value (cadr sects)))
- (if (consp title)
- (mapcar #'display-sections sects)
- (if (consp value)
- (progn
- (print-sect-title title)
- (incf *section-indent*)
- (display-sections value)
- (decf *section-indent*))
- (display-one-section title value))))))
-
-(defun display-page (pkg-name pkg-base ftp-base ftp-url sects)
- (let ((*section-indent* 3)
- (*ftp-base* ftp-base)
- (*ftp-url* ftp-url)
- (*base-name* pkg-base)
- (*signed* nil))
- (display-header pkg-name ftp-url)
- (mapcar #'display-sections sects)
- (display-footer)))
-
-(defun std-dl-page (pkg-name pkg-base ftp-base ftp-url)
- (let ((base (parse-namestring ftp-base)))
- (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
- (zip-path (make-pathname :defaults base :type "zip" :name :wild))
- (doc-path (make-pathname :defaults base :type "pdf" :name :wild)))
- (display-page pkg-name pkg-base ftp-base ftp-url
- `(("Manual" ,doc-path)
- ("Source Code"
- (("Unix (.tar.gz)" ,tgz-path)
- ("Windows (.zip)" ,zip-path))))))))
-
-(defun full-dl-page (pkg-name pkg-base ftp-base ftp-url)
- (let ((base (parse-namestring ftp-base)))
- (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
- (zip-path (make-pathname :defaults base :type "zip" :name :wild))
- (doc-path (make-pathname :defaults base :type "pdf" :name :wild))
- (deb-path (merge-pathnames
- (make-pathname :directory '(:relative "linux-debian")
- :type :wild :name :wild)
- base))
- (rpm-path (merge-pathnames
- (make-pathname :directory '(:relative "linux-rpm")
- :type :wild :name :wild)
- base))
- (w32-path (merge-pathnames
- (make-pathname :directory '(:relative "w32")
- :type :wild :name :wild)
- base)))
- (display-page pkg-name pkg-base ftp-base ftp-url
- `(("Manual" ,doc-path)
- ("Source Code"
- (("Unix (.tar.gz)" ,tgz-path)
- ("Windows (.zip)" ,zip-path)))
- ("Binaries"
- (("Linux Binaries"
- (("Debian Linux" ,deb-path)
- ("RedHat Linux" ,rpm-path)))
- ("Windows Binaries" ,w32-path))))))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: downloads.cl
+;;;; Purpose: Generate downloads page
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: downloads.lisp,v 1.1 2002/09/30 10:26:43 kevin Exp $
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+
+(defvar *ftp-base*)
+(defvar *ftp-url*)
+(defvar *base-name*)
+(defvar *section-indent* 0)
+(defvar *signed* nil)
+
+(defun list-files (files)
+ "List files in a directory for downloading"
+ ;;files.sort()
+ (mapcar #'print-file files))
+
+(defun strip-ftp-base (file)
+ (let ((fdir (pathname-directory file))
+ (bdir (pathname-directory *ftp-base*)))
+ (make-pathname
+ :name (pathname-name file)
+ :type (pathname-type file)
+ :directory
+ (when (> (length bdir) (length fdir))
+ (append '(:absolute)
+ (subseq (length bdir) (length fdir) fdir))))))
+
+(defun print-file (file)
+ (let ((size 0)
+ (modtime (date-string (file-write-date file)))
+ (basename (namestring
+ (make-pathname :name (pathname-name file)
+ :type (pathname-type file))))
+ (ftp-name (strip-ftp-base file))
+ (sig-path (concatenate 'string (namestring file) ".asc")))
+ (when (plusp (length basename))
+ (with-open-file (strm file :direction :input)
+ (setq size (round (/ (file-length strm) 1024))))
+ (lml-print "<a href=\"~A~A\">~A</a>" *ftp-url* ftp-name basename)
+ (lml-print "<span class=\"modtime\">")
+ (lml-print " (~A, <b>~:D <span style=\"font-size:90%;\">KB</span></b>)</span>" modtime size)
+ (when (probe-file sig-path)
+ (setq *signed* t)
+ (lml-print " [<a href=\"~A~A.asc\">Signature</a>]" *ftp-url* ftp-name))
+ (br))))
+
+(defun display-header (name url)
+ (lml-print "<h1>Download</h1>")
+ (lml-print "<div class=\"mainbody\">")
+ (lml-print "<h3>Browse ~A FTP Site</h3>" name)
+ (lml-print "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url))
+
+(defun display-footer ()
+ (when *signed*
+ (lml-print "<h3>GPG Public Key</h3>")
+ (lml-print "Use this <a href=\"https://www.b9.com/key.asc\">key</a> to verify file signtatures"))
+ (lml-print "</div>"))
+
+(defun print-sect-title (title)
+ (lml-print "<h~D>~A</h~D>" *section-indent* title *section-indent*))
+
+(defun match-base-name? (name)
+ (let ((len-base-name (length *base-name*)))
+ (when (>= (length name) len-base-name)
+ (dotimes (i len-base-name)
+ (declare (fixnum i))
+ (unless (char= (char *base-name* i)
+ (char name i))
+ (return-from match-base-name? nil)))))
+ t)
+
+(defun filter-against-base (files)
+ (let ((filtered '()))
+ (dolist (f files)
+ (let ((name (pathname-name f)))
+ (when (match-base-name? name)
+ (push f filtered))))
+ (when filtered
+ (sort filtered #'(lambda (a b) (when (and a b)
+ (string<
+ (namestring a)
+ (namestring b))))))))
+
+(defun display-one-section (title pat)
+ (let ((files (filter-against-base (directory pat))))
+ (when files
+ (print-sect-title title)
+ (lml-print "<div style=\"padding-left: 20pt;\">")
+ (list-files files)
+ (lml-print"</div>"))))
+
+
+(defun display-sections (sects)
+ (when sects
+ (let ((title (car sects))
+ (value (cadr sects)))
+ (if (consp title)
+ (mapcar #'display-sections sects)
+ (if (consp value)
+ (progn
+ (print-sect-title title)
+ (incf *section-indent*)
+ (display-sections value)
+ (decf *section-indent*))
+ (display-one-section title value))))))
+
+(defun display-page (pkg-name pkg-base ftp-base ftp-url sects)
+ (let ((*section-indent* 3)
+ (*ftp-base* ftp-base)
+ (*ftp-url* ftp-url)
+ (*base-name* pkg-base)
+ (*signed* nil))
+ (display-header pkg-name ftp-url)
+ (mapcar #'display-sections sects)
+ (display-footer)))
+
+(defun std-dl-page (pkg-name pkg-base ftp-base ftp-url)
+ (let ((base (parse-namestring ftp-base)))
+ (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
+ (zip-path (make-pathname :defaults base :type "zip" :name :wild))
+ (doc-path (make-pathname :defaults base :type "pdf" :name :wild)))
+ (display-page pkg-name pkg-base ftp-base ftp-url
+ `(("Manual" ,doc-path)
+ ("Source Code"
+ (("Unix (.tar.gz)" ,tgz-path)
+ ("Windows (.zip)" ,zip-path))))))))
+
+(defun full-dl-page (pkg-name pkg-base ftp-base ftp-url)
+ (let ((base (parse-namestring ftp-base)))
+ (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
+ (zip-path (make-pathname :defaults base :type "zip" :name :wild))
+ (doc-path (make-pathname :defaults base :type "pdf" :name :wild))
+ (deb-path (merge-pathnames
+ (make-pathname :directory '(:relative "linux-debian")
+ :type :wild :name :wild)
+ base))
+ (rpm-path (merge-pathnames
+ (make-pathname :directory '(:relative "linux-rpm")
+ :type :wild :name :wild)
+ base))
+ (w32-path (merge-pathnames
+ (make-pathname :directory '(:relative "w32")
+ :type :wild :name :wild)
+ base)))
+ (display-page pkg-name pkg-base ftp-base ftp-url
+ `(("Manual" ,doc-path)
+ ("Source Code"
+ (("Unix (.tar.gz)" ,tgz-path)
+ ("Windows (.zip)" ,zip-path)))
+ ("Binaries"
+ (("Linux Binaries"
+ (("Debian Linux" ,deb-path)
+ ("RedHat Linux" ,rpm-path)))
+ ("Windows Binaries" ,w32-path))))))))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: files.cl
-;;;; Purpose: File and directory functions for LML
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Aug 2002
-;;;;
-;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; LML users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License v2
-;;;; (http://www.gnu.org/licenses/gpl.html)
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :lml)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *output-dir* nil)
- (defvar *sources-dir* nil)
- )
-
-(defvar *html-output* *standard-output*)
-
-(defmacro lml-file-name (file &optional (type :source))
- (let ((f file))
- (when (and (consp f) (eql (car f) 'cl:quote))
- (setq f (cadr f)))
- (when (symbolp f)
- (setq f (string-downcase (symbol-name f))))
- (when (stringp f)
- (unless (position #\. f)
- (setq f (concatenate 'string f ".html"))))
- (if *sources-dir*
- (make-pathname :defaults (ecase type
- (:source *sources-dir*)
- (:output *output-dir*))
- :name `,(pathname-name f)
- :type `,(pathname-type f))
- (if (stringp f)
- (parse-namestring f)
- f))))
-
-(defmacro with-dir ((output-dir &key sources) &body body)
- (when (stringp output-dir)
- (setq output-dir (parse-namestring output-dir)))
- (unless sources
- (setq sources output-dir))
- `(let ((*output-dir* ,output-dir)
- (*sources-dir* ,sources))
- ,@body))
-
-(defun lml-load-path (file)
- (if (probe-file file)
- (with-open-file (in file :direction :input)
- (do ((form (read in nil 'lml::eof) (read in nil 'lml::eof)))
- ((eq form 'lml::eof))
- (eval form)))
- (format *trace-output* "Warning: unable to load LML file ~S" file)))
-
-(defun process-dir (dir &key sources)
- (with-dir (dir :sources sources)
- (let ((lml-files (directory
- (make-pathname :defaults *sources-dir*
- :name :wild
- :type "lml"))))
- (dolist (file lml-files)
- (format *trace-output* "~&; Processing ~A~%" file)
- (lml-load-path file)))))
-
-(defun lml-load (file)
- (lml-load-path (eval `(lml-file-name ,file :source))))
-
-(defun include-file (file)
- (print-file-contents file *html-output*))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: files.cl
+;;;; Purpose: File and directory functions for LML
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *output-dir* nil)
+ (defvar *sources-dir* nil)
+ )
+
+(defvar *html-output* *standard-output*)
+
+(defmacro lml-file-name (file &optional (type :source))
+ (let ((f file))
+ (when (and (consp f) (eql (car f) 'cl:quote))
+ (setq f (cadr f)))
+ (when (symbolp f)
+ (setq f (string-downcase (symbol-name f))))
+ (when (stringp f)
+ (unless (position #\. f)
+ (setq f (concatenate 'string f ".html"))))
+ (if *sources-dir*
+ (make-pathname :defaults (ecase type
+ (:source *sources-dir*)
+ (:output *output-dir*))
+ :name `,(pathname-name f)
+ :type `,(pathname-type f))
+ (if (stringp f)
+ (parse-namestring f)
+ f))))
+
+(defmacro with-dir ((output-dir &key sources) &body body)
+ (when (stringp output-dir)
+ (setq output-dir (parse-namestring output-dir)))
+ (unless sources
+ (setq sources output-dir))
+ `(let ((*output-dir* ,output-dir)
+ (*sources-dir* ,sources))
+ ,@body))
+
+(defun lml-load-path (file)
+ (if (probe-file file)
+ (with-open-file (in file :direction :input)
+ (do ((form (read in nil 'lml::eof) (read in nil 'lml::eof)))
+ ((eq form 'lml::eof))
+ (eval form)))
+ (format *trace-output* "Warning: unable to load LML file ~S" file)))
+
+(defun process-dir (dir &key sources)
+ (with-dir (dir :sources sources)
+ (let ((lml-files (directory
+ (make-pathname :defaults *sources-dir*
+ :name :wild
+ :type "lml"))))
+ (dolist (file lml-files)
+ (format *trace-output* "~&; Processing ~A~%" file)
+ (lml-load-path file)))))
+
+(defun lml-load (file)
+ (lml-load-path (eval `(lml-file-name ,file :source))))
+
+(defun include-file (file)
+ (print-file-contents file *html-output*))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2002
;;;;
-;;;; $Id: lml.asd,v 1.9 2002/09/20 06:37:38 kevin Exp $
+;;;; $Id: lml.asd,v 1.10 2002/09/30 10:26:43 kevin Exp $
;;;;
;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(:file "downloads" :depends-on ("lml"))
))
-(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'lml))))
- "cl")
-
(when (ignore-errors (find-class 'load-compiled-op))
(defmethod perform :after ((op load-compiled-op) (c (eql (find-system :lml))))
(pushnew :lml cl:*features*)))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: lml.cl
-;;;; Purpose: Lisp Markup Language functions
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Aug 2002
-;;;;
-;;;; $Id: lml.cl,v 1.13 2002/09/16 10:18:19 kevin Exp $
-;;;;
-;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; LML users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License v2
-;;;; (http://www.gnu.org/licenses/gpl.html)
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :lml)
-
-(defun html4-prologue-string ()
- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
-
-(defun xml-prologue-string ()
- "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>")
-
-(defun xhtml-prologue-string ()
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
-
-(defvar *print-spaces* nil)
-(defvar *indent* 0)
-(defun reset-indent ()
- (setq *indent* 0))
-
-(defun lml-print (str &rest args)
- (when (streamp *html-output*)
- (when *print-spaces* (indent-spaces *indent* *html-output*))
- (if args
- (apply #'format *html-output* str args)
- (princ str *html-output*))
- (when *print-spaces* (format *html-output* "~%"))
- (values)))
-
-(defmacro lml-line (str &rest args)
- `(lml-print ,str ,@args))
-
-(defun lml-print-date (date)
- (lml-print (date-string date)))
-
-(defmacro lml-exec-body (&body forms)
- `(progn
- ,@(mapcar
- #'(lambda (form)
- (etypecase form
- (string
- `(lml-print ,form))
- (number
- `(lml-print "~D" ,form))
- (symbol
- `(lml-print (string-downcase (symbol-name ,form))))
- (nil
- nil)
- (cons
- form)))
- forms)))
-
-(defmacro with-attr-string (tag attr-string &body body)
- (let ((attr (gensym)))
- `(let ((,attr ,attr-string))
- (lml-print "<~(~A~)~A>" ',tag
- (if (and (stringp ,attr) (plusp (length ,attr)))
- (format nil "~A" ,attr)
- ""))
- (incf *indent*)
- (lml-exec-body ,@body)
- (decf *indent*)
- (lml-print "</~(~A~)>" ',tag))))
-
-(defun one-keyarg-string (key value)
- "Return attribute string for keys"
- (format nil "~(~A~)=\"~A\"" key
- (typecase value
- (symbol
- (string-downcase (symbol-name value)))
- (string
- value)
- (t
- (eval value)))))
-
-(defmacro with-keyargs (tag keyargs &body body)
- (let ((attr (gensym))
- (kv (gensym)))
- `(progn
- (let ((,attr '()))
- (dolist (,kv ',keyargs)
- (awhen (cadr ,kv)
- (push (one-keyarg-string (car ,kv) it) ,attr)))
- (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
-
-(defmacro with (tag &rest args)
- (let ((body '())
- (keyargs '())
- (n (length args)))
- (do ((i 0 (1+ i)))
- ((> i (1- n)))
- (let ((arg (nth i args))
- (value (when (< (1+ i) n)
- (nth (1+ i) args))))
- (if (keyword-symbol? arg)
- (progn
- (push (list arg value) keyargs)
- (incf i))
- (push arg body))))
- `(with-keyargs ,tag ,keyargs ,@(nreverse body))))
-
-
-(defmacro keyargs-string (&rest args)
- "Returns a string of attributes and values. Result contains a leading space."
- (let ((keyarg-list '()))
- (loop for ( name val ) on args by #'cddr
- do
- (when val
- (push (one-keyarg-string name val) keyarg-list)))
- (list-to-spaced-string (nreverse keyarg-list))))
-
-
-(defmacro xhtml-prologue ()
- `(progn
- (lml-print "~A~%" (xml-prologue-string))
- (lml-print "~A~%" (xhtml-prologue-string))))
-
-(defmacro link (dest &body body)
- `(with a :href ,dest ,@body))
-
-(defmacro link-c (class dest &body body)
- `(with a :href ,dest :class ,class ,@body))
-
-(defmacro img (dest &key class id alt style width height align)
- (let ((attr
- (eval `(keyargs-string :class ,class :id ,id :alt ,alt :style ,style
- :width ,width :height ,height :align ,align))))
- `(lml-print ,(format nil "<img src=\"~A\"~A />" dest attr))))
-
-(defmacro input (&key name class id type style size maxlength value)
- (let ((attr
- (eval `(keyargs-string :name ,name :class ,class :id ,id :style ,style
- :size ,size :maxlength ,maxlength :value ,value
- :type ,type))))
- `(lml-print ,(format nil "<input~A />" attr))))
-
-(defmacro meta (name content)
- `(with meta :name ,name :content ,content))
-
-(defmacro meta-key (&key name content http-equiv)
- `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
-
-(defmacro br ()
- `(lml-print "<br />"))
-
-(defmacro hr ()
- `(lml-print "<hr />"))
-
-(defmacro lml-tag-macro (tag)
- `(progn
- (defmacro ,tag (&body body)
- `(with ,',tag ,@body))
- (export ',tag)))
-
-(defmacro lml-tag-class-macro (tag)
- (let ((name (intern (format nil "~A-~A" tag :c))))
- `(progn
- (defmacro ,name (&body body)
- `(with ,',tag :class ,(car body) ,@(cdr body)))
- (export ',name))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *macro-list*
- '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td tr body head
- html title pre tt u dl dt dd kbd code form))
- (export '(link link-c br hr img input meta meta-key))
- (export *macro-list*))
-
-(loop for i in *macro-list*
- do
- (eval `(lml-tag-macro ,i))
- (eval `(lml-tag-class-macro ,i)))
-
-(defmacro print-page (title &body body)
- `(html
- (head
- (title ,title))
- (body ,@body)))
-
-(defmacro page (out-file &body body)
- `(with-open-file (*html-output*
- (lml-file-name ,out-file :output)
- :direction :output
- :if-exists :supersede)
- (xhtml-prologue)
- (html :xmlns "http://www.w3.org/1999/xhtml"
- ,@body)))
-
-(defun new-string ()
- (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
-
-(set-macro-character #\[
- #'(lambda (stream char)
- (declare (ignore char))
- (let ((forms '())
- (curr-string (new-string))
- (paren-level 0)
- (got-comma nil))
- (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
- ((eql ch #\]))
- (if got-comma
- (if (eql ch #\()
- ;; Starting top-level ,(
- (progn
- (push `(lml-print ,curr-string) forms)
- (setq curr-string (new-string))
- (setq got-comma nil)
- (vector-push #\( curr-string)
- (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
- ((and (eql ch #\)) (zerop paren-level)))
- (when (eql ch #\])
- (format *trace-output* "Syntax error reading #\]")
- (return nil))
- (case ch
- (#\(
- (incf paren-level))
- (#\)
- (decf paren-level)))
- (vector-push-extend ch curr-string))
- (vector-push-extend #\) curr-string)
- (let ((eval-string (read-from-string curr-string))
- (res (gensym)))
- (push
- `(let ((,res ,eval-string))
- (when ,res
- (lml-print ,res)))
- forms))
- (setq curr-string (new-string)))
- ;; read comma, then non #\( char
- (progn
- (unless (eql ch #\,)
- (setq got-comma nil))
- (vector-push-extend #\, curr-string) ;; push previous command
- (vector-push-extend ch curr-string)))
- ;; previous character is not a comma
- (if (eql ch #\,)
- (setq got-comma t)
- (progn
- (setq got-comma nil)
- (vector-push-extend ch curr-string)))))
- (push `(lml-print ,curr-string) forms)
- `(progn ,@(nreverse forms)))))
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: lml.cl
+;;;; Purpose: Lisp Markup Language functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: lml.lisp,v 1.1 2002/09/30 10:26:43 kevin Exp $
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+(defun html4-prologue-string ()
+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
+
+(defun xml-prologue-string ()
+ "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>")
+
+(defun xhtml-prologue-string ()
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
+
+(defvar *print-spaces* nil)
+(defvar *indent* 0)
+(defun reset-indent ()
+ (setq *indent* 0))
+
+(defun lml-print (str &rest args)
+ (when (streamp *html-output*)
+ (when *print-spaces* (indent-spaces *indent* *html-output*))
+ (if args
+ (apply #'format *html-output* str args)
+ (princ str *html-output*))
+ (when *print-spaces* (format *html-output* "~%"))
+ (values)))
+
+(defmacro lml-line (str &rest args)
+ `(lml-print ,str ,@args))
+
+(defun lml-print-date (date)
+ (lml-print (date-string date)))
+
+(defmacro lml-exec-body (&body forms)
+ `(progn
+ ,@(mapcar
+ #'(lambda (form)
+ (etypecase form
+ (string
+ `(lml-print ,form))
+ (number
+ `(lml-print "~D" ,form))
+ (symbol
+ `(lml-print (string-downcase (symbol-name ,form))))
+ (nil
+ nil)
+ (cons
+ form)))
+ forms)))
+
+(defmacro with-attr-string (tag attr-string &body body)
+ (let ((attr (gensym)))
+ `(let ((,attr ,attr-string))
+ (lml-print "<~(~A~)~A>" ',tag
+ (if (and (stringp ,attr) (plusp (length ,attr)))
+ (format nil "~A" ,attr)
+ ""))
+ (incf *indent*)
+ (lml-exec-body ,@body)
+ (decf *indent*)
+ (lml-print "</~(~A~)>" ',tag))))
+
+(defun one-keyarg-string (key value)
+ "Return attribute string for keys"
+ (format nil "~(~A~)=\"~A\"" key
+ (typecase value
+ (symbol
+ (string-downcase (symbol-name value)))
+ (string
+ value)
+ (t
+ (eval value)))))
+
+(defmacro with-keyargs (tag keyargs &body body)
+ (let ((attr (gensym))
+ (kv (gensym)))
+ `(progn
+ (let ((,attr '()))
+ (dolist (,kv ',keyargs)
+ (awhen (cadr ,kv)
+ (push (one-keyarg-string (car ,kv) it) ,attr)))
+ (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
+
+(defmacro with (tag &rest args)
+ (let ((body '())
+ (keyargs '())
+ (n (length args)))
+ (do ((i 0 (1+ i)))
+ ((> i (1- n)))
+ (let ((arg (nth i args))
+ (value (when (< (1+ i) n)
+ (nth (1+ i) args))))
+ (if (keyword-symbol? arg)
+ (progn
+ (push (list arg value) keyargs)
+ (incf i))
+ (push arg body))))
+ `(with-keyargs ,tag ,keyargs ,@(nreverse body))))
+
+
+(defmacro keyargs-string (&rest args)
+ "Returns a string of attributes and values. Result contains a leading space."
+ (let ((keyarg-list '()))
+ (loop for ( name val ) on args by #'cddr
+ do
+ (when val
+ (push (one-keyarg-string name val) keyarg-list)))
+ (list-to-spaced-string (nreverse keyarg-list))))
+
+
+(defmacro xhtml-prologue ()
+ `(progn
+ (lml-print "~A~%" (xml-prologue-string))
+ (lml-print "~A~%" (xhtml-prologue-string))))
+
+(defmacro link (dest &body body)
+ `(with a :href ,dest ,@body))
+
+(defmacro link-c (class dest &body body)
+ `(with a :href ,dest :class ,class ,@body))
+
+(defmacro img (dest &key class id alt style width height align)
+ (let ((attr
+ (eval `(keyargs-string :class ,class :id ,id :alt ,alt :style ,style
+ :width ,width :height ,height :align ,align))))
+ `(lml-print ,(format nil "<img src=\"~A\"~A />" dest attr))))
+
+(defmacro input (&key name class id type style size maxlength value)
+ (let ((attr
+ (eval `(keyargs-string :name ,name :class ,class :id ,id :style ,style
+ :size ,size :maxlength ,maxlength :value ,value
+ :type ,type))))
+ `(lml-print ,(format nil "<input~A />" attr))))
+
+(defmacro meta (name content)
+ `(with meta :name ,name :content ,content))
+
+(defmacro meta-key (&key name content http-equiv)
+ `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
+
+(defmacro br ()
+ `(lml-print "<br />"))
+
+(defmacro hr ()
+ `(lml-print "<hr />"))
+
+(defmacro lml-tag-macro (tag)
+ `(progn
+ (defmacro ,tag (&body body)
+ `(with ,',tag ,@body))
+ (export ',tag)))
+
+(defmacro lml-tag-class-macro (tag)
+ (let ((name (intern (format nil "~A-~A" tag :c))))
+ `(progn
+ (defmacro ,name (&body body)
+ `(with ,',tag :class ,(car body) ,@(cdr body)))
+ (export ',name))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *macro-list*
+ '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td tr body head
+ html title pre tt u dl dt dd kbd code form))
+ (export '(link link-c br hr img input meta meta-key))
+ (export *macro-list*))
+
+(loop for i in *macro-list*
+ do
+ (eval `(lml-tag-macro ,i))
+ (eval `(lml-tag-class-macro ,i)))
+
+(defmacro print-page (title &body body)
+ `(html
+ (head
+ (title ,title))
+ (body ,@body)))
+
+(defmacro page (out-file &body body)
+ `(with-open-file (*html-output*
+ (lml-file-name ,out-file :output)
+ :direction :output
+ :if-exists :supersede)
+ (xhtml-prologue)
+ (html :xmlns "http://www.w3.org/1999/xhtml"
+ ,@body)))
+
+(defun new-string ()
+ (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
+
+(set-macro-character #\[
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (let ((forms '())
+ (curr-string (new-string))
+ (paren-level 0)
+ (got-comma nil))
+ (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
+ ((eql ch #\]))
+ (if got-comma
+ (if (eql ch #\()
+ ;; Starting top-level ,(
+ (progn
+ (push `(lml-print ,curr-string) forms)
+ (setq curr-string (new-string))
+ (setq got-comma nil)
+ (vector-push #\( curr-string)
+ (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
+ ((and (eql ch #\)) (zerop paren-level)))
+ (when (eql ch #\])
+ (format *trace-output* "Syntax error reading #\]")
+ (return nil))
+ (case ch
+ (#\(
+ (incf paren-level))
+ (#\)
+ (decf paren-level)))
+ (vector-push-extend ch curr-string))
+ (vector-push-extend #\) curr-string)
+ (let ((eval-string (read-from-string curr-string))
+ (res (gensym)))
+ (push
+ `(let ((,res ,eval-string))
+ (when ,res
+ (lml-print ,res)))
+ forms))
+ (setq curr-string (new-string)))
+ ;; read comma, then non #\( char
+ (progn
+ (unless (eql ch #\,)
+ (setq got-comma nil))
+ (vector-push-extend #\, curr-string) ;; push previous command
+ (vector-push-extend ch curr-string)))
+ ;; previous character is not a comma
+ (if (eql ch #\,)
+ (setq got-comma t)
+ (progn
+ (setq got-comma nil)
+ (vector-push-extend ch curr-string)))))
+ (push `(lml-print ,curr-string) forms)
+ `(progn ,@(nreverse forms)))))
+
+
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: package.cl
-;;;; Purpose: Package file for Lisp Markup Language
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Aug 2002
-;;;;
-;;;; $Id: package.cl,v 1.4 2002/09/16 07:11:12 kevin Exp $
-;;;;
-;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; LML users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License v2
-;;;; (http://www.gnu.org/licenses/gpl.html)
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-(defpackage #:lisp-markup-language
- (:use #:common-lisp)
- (:nicknames #:lml)
- (:export
-
- ;; lml.cl
- #:reset-indent
- #:with
- #:print-page
- #:page
- #:lml-print
- #:lml-print-date
-
- ;; files.cl
- #:with-dir
- #:process-dir
- #:lml-load
- #:include-file
-
- ;; stdsite.cl
- #:print-std-page
- #:std-page
- #:std-body
- #:std-head
- #:titled-pre-section
-
- ;; downloads.cl
- #:std-dl-page
- #:full-dl-page
-
- ;; utils.cl
- #:lml-quit
- #:lml-cwd
-))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.cl
+;;;; Purpose: Package file for Lisp Markup Language
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: package.lisp,v 1.1 2002/09/30 10:26:43 kevin Exp $
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(defpackage #:lisp-markup-language
+ (:use #:common-lisp)
+ (:nicknames #:lml)
+ (:export
+
+ ;; lml.cl
+ #:reset-indent
+ #:with
+ #:print-page
+ #:page
+ #:lml-print
+ #:lml-print-date
+
+ ;; files.cl
+ #:with-dir
+ #:process-dir
+ #:lml-load
+ #:include-file
+
+ ;; stdsite.cl
+ #:print-std-page
+ #:std-page
+ #:std-body
+ #:std-head
+ #:titled-pre-section
+
+ ;; downloads.cl
+ #:std-dl-page
+ #:full-dl-page
+
+ ;; utils.cl
+ #:lml-quit
+ #:lml-cwd
+))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: stdsite.cl
-;;;; Purpose: Functions to create my standard style sites
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Aug 2002
-;;;;
-;;;; $Id: stdsite.cl,v 1.2 2002/09/20 19:13:51 kevin Exp $
-;;;;
-;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; LML users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License v2
-;;;; (http://www.gnu.org/licenses/gpl.html)
-;;;; *************************************************************************
-
-;;; A "standard site" is a format for a certain style of web page.
-;;; It is based on the LML package.
-;;; A stdsite page expects to include the following files:
-;;; head.lml_
-;;; banner.lml_
-;;; content.lml_
-;;; footer.lml_
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :lml)
-
-(defmacro std-head (title &body body)
- `(head
- (title ,title)
- (lml-load #p"head.lml_")
- ,@body))
-
-
-(defun std-footer (file)
- (div-c "disclaimsec"
- (let ((src-file (make-pathname
- :defaults *sources-dir*
- :type "lml"
- :name (pathname-name file))))
- (when (probe-file src-file)
- (div-c "lastmod"
- (lml-print "Last modified: ~A" (date-string (file-write-date src-file))))))
- (lml-load #p"footer.lml_"))
- (values))
-
-
-(defmacro std-body (file &body body)
- `(body
- (lml-load #p"banner.lml_")
- (table-c "stdbodytable" :border "0" :cellpadding "3"
- (tbody
- (tr :valign "top"
- (td-c "stdcontentcell"
- (lml-load #p"contents.lml_"))
- (td :valign "top"
- ,@body
- (std-footer ,file)))))))
-
-
-(defmacro print-std-page (file title &body body)
- `(progn
- (xhtml-prologue)
- (html :xmlns "http://www.w3.org/1999/xhtml"
- (std-head ,title)
- (std-body ,file ,@body))))
-
-(defmacro std-page (out-file title &body body)
- `(let ((*indent* 0))
- (with-open-file (*html-output* (lml-file-name ,out-file :output)
- :direction :output
- :if-exists :supersede)
- (print-std-page (lml-file-name ,out-file :source) ,title ,@body))))
-
-(defmacro titled-pre-section (title &body body)
- `(progn
- (h1 ,title)
- (pre :style "padding-left:30pt;"
- ,@body)))
-
-
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: stdsite.cl
+;;;; Purpose: Functions to create my standard style sites
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: stdsite.lisp,v 1.1 2002/09/30 10:26:43 kevin Exp $
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+;;; A "standard site" is a format for a certain style of web page.
+;;; It is based on the LML package.
+;;; A stdsite page expects to include the following files:
+;;; head.lml_
+;;; banner.lml_
+;;; content.lml_
+;;; footer.lml_
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+(defmacro std-head (title &body body)
+ `(head
+ (title ,title)
+ (lml-load #p"head.lml_")
+ ,@body))
+
+
+(defun std-footer (file)
+ (div-c "disclaimsec"
+ (let ((src-file (make-pathname
+ :defaults *sources-dir*
+ :type "lml"
+ :name (pathname-name file))))
+ (when (probe-file src-file)
+ (div-c "lastmod"
+ (lml-print "Last modified: ~A" (date-string (file-write-date src-file))))))
+ (lml-load #p"footer.lml_"))
+ (values))
+
+
+(defmacro std-body (file &body body)
+ `(body
+ (lml-load #p"banner.lml_")
+ (table-c "stdbodytable" :border "0" :cellpadding "3"
+ (tbody
+ (tr :valign "top"
+ (td-c "stdcontentcell"
+ (lml-load #p"contents.lml_"))
+ (td :valign "top"
+ ,@body
+ (std-footer ,file)))))))
+
+
+(defmacro print-std-page (file title &body body)
+ `(progn
+ (xhtml-prologue)
+ (html :xmlns "http://www.w3.org/1999/xhtml"
+ (std-head ,title)
+ (std-body ,file ,@body))))
+
+(defmacro std-page (out-file title &body body)
+ `(let ((*indent* 0))
+ (with-open-file (*html-output* (lml-file-name ,out-file :output)
+ :direction :output
+ :if-exists :supersede)
+ (print-std-page (lml-file-name ,out-file :source) ,title ,@body))))
+
+(defmacro titled-pre-section (title &body body)
+ `(progn
+ (h1 ,title)
+ (pre :style "padding-left:30pt;"
+ ,@body)))
+
+
+
+++ /dev/null
-;;; $Id: utils.cl,v 1.6 2002/09/20 18:55:03 kevin Exp $
-;;;;
-;;;; General purpose utilities
-
-(in-package :lml)
-
-
-(defmacro aif (test then &optional else)
- `(let ((it ,test))
- (if it ,then ,else)))
-
-(defmacro awhen (test-form &body body)
- `(aif ,test-form
- (progn ,@body)))
-
-(defun keyword-symbol? (x)
- "Returns T if object is a symbol in the keyword package"
- (and (symbolp x)
- (string-equal "keyword" (package-name (symbol-package x)))))
-
-(defun list-to-spaced-string (list)
- (format nil "~{ ~A~}" list))
-
-(defun indent-spaces (n &optional (stream *standard-output*))
- "Indent n*2 spaces to output stream"
- (let ((fmt (format nil "~~~DT" (+ n n))))
- (format stream fmt)))
-
-(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 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))))
-
-(defun lml-quit (&optional (code 0))
- "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
- #+allegro (excl:exit code)
- #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
- #+cmu (ext:quit code)
- #+cormanlisp (win32:exitprocess code)
- #+gcl (lisp:bye code)
- #+lispworks (lw:quit :status code)
- #+lucid (lcl:quit code)
- #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
- #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
- (error 'not-implemented :proc (list 'quit code)))
-
-
-(defun lml-cwd ()
- "Returns the current working directory. Based on CLOCC's DEFAULT-DIRECTORY function."
- #+allegro (excl:current-directory)
- #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
- #+cmu (ext:default-directory)
- #+cormanlisp (ccl:get-current-directory)
- #+lispworks (hcl:get-working-directory)
- #+lucid (lcl:working-directory)
- #-(or allegro clisp cmu cormanlisp lispworks lucid) (truename "."))
-
-
--- /dev/null
+;;; $Id: utils.lisp,v 1.1 2002/09/30 10:26:43 kevin Exp $
+;;;;
+;;;; General purpose utilities
+
+(in-package :lml)
+
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+ `(aif ,test-form
+ (progn ,@body)))
+
+(defun keyword-symbol? (x)
+ "Returns T if object is a symbol in the keyword package"
+ (and (symbolp x)
+ (string-equal "keyword" (package-name (symbol-package x)))))
+
+(defun list-to-spaced-string (list)
+ (format nil "~{ ~A~}" list))
+
+(defun indent-spaces (n &optional (stream *standard-output*))
+ "Indent n*2 spaces to output stream"
+ (let ((fmt (format nil "~~~DT" (+ n n))))
+ (format stream fmt)))
+
+(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 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))))
+
+(defun lml-quit (&optional (code 0))
+ "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
+ #+allegro (excl:exit code)
+ #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
+ #+cmu (ext:quit code)
+ #+cormanlisp (win32:exitprocess code)
+ #+gcl (lisp:bye code)
+ #+lispworks (lw:quit :status code)
+ #+lucid (lcl:quit code)
+ #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
+ #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
+ (error 'not-implemented :proc (list 'quit code)))
+
+
+(defun lml-cwd ()
+ "Returns the current working directory. Based on CLOCC's DEFAULT-DIRECTORY function."
+ #+allegro (excl:current-directory)
+ #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
+ #+cmu (ext:default-directory)
+ #+cormanlisp (ccl:get-current-directory)
+ #+lispworks (hcl:get-working-directory)
+ #+lucid (lcl:working-directory)
+ #-(or allegro clisp cmu cormanlisp lispworks lucid) (truename "."))
+
+
projects / lml.git / commitdiff