From: Kevin M. Rosenberg Date: Mon, 30 Sep 2002 10:28:40 +0000 (+0000) Subject: r2915: *** empty log message *** X-Git-Tag: v2.5.5~149 X-Git-Url: http://git.kpe.io/?p=lml.git;a=commitdiff_plain;h=e741d288978f9a65554235ecb3115db8eef60b54 r2915: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 37ea6bf..59b7675 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-lml (1.1.0-1) unstable; urgency=low + + * Rename .cl files to .lisp + + -- Kevin M. Rosenberg Mon, 30 Sep 2002 04:23:11 -0600 + cl-lml (1.0.9-2) unstable; urgency=low * Add missing dependency (closes: 162090) diff --git a/debian/rules b/debian/rules index 0bafb8a..36fca29 100755 --- a/debian/rules +++ b/debian/rules @@ -44,7 +44,7 @@ install: build 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 @@ -58,7 +58,7 @@ binary-arch: build install 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 diff --git a/debian/upload.sh b/debian/upload.sh index 252e13d..1b922b7 100755 --- a/debian/upload.sh +++ b/debian/upload.sh @@ -1,4 +1,4 @@ #!/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 $* diff --git a/doc/Makefile b/doc/Makefile index dadee61..531aded 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -3,7 +3,7 @@ all: site site: - lisp -init `pwd`/make.cl + lisp -init `pwd`/make.lisp clean: @rm -f *~ \#*\# .\#* memdump diff --git a/doc/make.cl b/doc/make.cl deleted file mode 100644 index 3ee1402..0000000 --- a/doc/make.cl +++ /dev/null @@ -1,7 +0,0 @@ -#+cmu (setq ext:*gc-verbose* nil) - -(require :lml) -(in-package :lml) -(let ((cwd (parse-namestring (lml-cwd)))) - (process-dir cwd)) -(lml-quit) diff --git a/doc/make.lisp b/doc/make.lisp new file mode 100644 index 0000000..3ee1402 --- /dev/null +++ b/doc/make.lisp @@ -0,0 +1,7 @@ +#+cmu (setq ext:*gc-verbose* nil) + +(require :lml) +(in-package :lml) +(let ((cwd (parse-namestring (lml-cwd)))) + (process-dir cwd)) +(lml-quit) diff --git a/downloads.cl b/downloads.cl deleted file mode 100644 index 7b528d4..0000000 --- a/downloads.cl +++ /dev/null @@ -1,171 +0,0 @@ -;;;; -*- 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" *ftp-url* ftp-name basename) - (lml-print "") - (lml-print " (~A, ~:D KB)" modtime size) - (when (probe-file sig-path) - (setq *signed* t) - (lml-print " [Signature]" *ftp-url* ftp-name)) - (br)))) - -(defun display-header (name url) - (lml-print "

Download

") - (lml-print "
") - (lml-print "

Browse ~A FTP Site

" name) - (lml-print "~A" url url)) - -(defun display-footer () - (when *signed* - (lml-print "

GPG Public Key

") - (lml-print "Use this key to verify file signtatures")) - (lml-print "
")) - -(defun print-sect-title (title) - (lml-print "~A" *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 "
") - (list-files files) - (lml-print"
")))) - - -(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)))))))) diff --git a/downloads.lisp b/downloads.lisp new file mode 100644 index 0000000..226095e --- /dev/null +++ b/downloads.lisp @@ -0,0 +1,171 @@ +;;;; -*- 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" *ftp-url* ftp-name basename) + (lml-print "") + (lml-print " (~A, ~:D KB)" modtime size) + (when (probe-file sig-path) + (setq *signed* t) + (lml-print " [Signature]" *ftp-url* ftp-name)) + (br)))) + +(defun display-header (name url) + (lml-print "

Download

") + (lml-print "
") + (lml-print "

Browse ~A FTP Site

" name) + (lml-print "~A" url url)) + +(defun display-footer () + (when *signed* + (lml-print "

GPG Public Key

") + (lml-print "Use this key to verify file signtatures")) + (lml-print "
")) + +(defun print-sect-title (title) + (lml-print "~A" *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 "
") + (list-files files) + (lml-print"
")))) + + +(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)))))))) diff --git a/files.cl b/files.cl deleted file mode 100644 index fd2366b..0000000 --- a/files.cl +++ /dev/null @@ -1,77 +0,0 @@ -;;;; -*- 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*)) diff --git a/files.lisp b/files.lisp new file mode 100644 index 0000000..fd2366b --- /dev/null +++ b/files.lisp @@ -0,0 +1,77 @@ +;;;; -*- 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*)) diff --git a/lml.asd b/lml.asd index 0e5c4b5..ed9244f 100644 --- a/lml.asd +++ b/lml.asd @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -39,9 +39,6 @@ (: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*))) diff --git a/lml.cl b/lml.cl deleted file mode 100644 index c3542bb..0000000 --- a/lml.cl +++ /dev/null @@ -1,259 +0,0 @@ -;;;; -*- 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 () - "") - -(defun xml-prologue-string () - "") - -(defun xhtml-prologue-string () - "") - -(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 "" ',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 "" 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 "" 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 "
")) - -(defmacro hr () - `(lml-print "
")) - -(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))))) - - diff --git a/lml.lisp b/lml.lisp new file mode 100644 index 0000000..c3a3c98 --- /dev/null +++ b/lml.lisp @@ -0,0 +1,259 @@ +;;;; -*- 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 () + "") + +(defun xml-prologue-string () + "") + +(defun xhtml-prologue-string () + "") + +(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 "" ',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 "" 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 "" 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 "
")) + +(defmacro hr () + `(lml-print "
")) + +(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))))) + + diff --git a/package.cl b/package.cl deleted file mode 100644 index cdcba6b..0000000 --- a/package.cl +++ /dev/null @@ -1,54 +0,0 @@ -;;;; -*- 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 -)) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..f71ee39 --- /dev/null +++ b/package.lisp @@ -0,0 +1,54 @@ +;;;; -*- 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 +)) diff --git a/stdsite.cl b/stdsite.cl deleted file mode 100644 index 306a65f..0000000 --- a/stdsite.cl +++ /dev/null @@ -1,84 +0,0 @@ -;;;; -*- 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))) - - - diff --git a/stdsite.lisp b/stdsite.lisp new file mode 100644 index 0000000..5c96142 --- /dev/null +++ b/stdsite.lisp @@ -0,0 +1,84 @@ +;;;; -*- 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))) + + + diff --git a/utils.cl b/utils.cl deleted file mode 100644 index 28d739f..0000000 --- a/utils.cl +++ /dev/null @@ -1,76 +0,0 @@ -;;; $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 ".")) - - diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..ed1f6a2 --- /dev/null +++ b/utils.lisp @@ -0,0 +1,76 @@ +;;; $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 ".")) + +