From 29aa484de6bd54a2a38792057a2d9f72b534a42c Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 13 Dec 2002 22:00:05 +0000 Subject: [PATCH] r3623: *** empty log message *** --- cl-symbols.lisp | 31 +++++++++++++++++++++++++++++- console.lisp | 51 +++++++++++++++++++++++++++++++++++++++++++++++++ genutils.lisp | 11 +---------- kmrcl.asd | 3 ++- package.lisp | 19 ++++++++++++++---- 5 files changed, 99 insertions(+), 16 deletions(-) create mode 100644 console.lisp diff --git a/cl-symbols.lisp b/cl-symbols.lisp index e8bfc90..97a9a92 100644 --- a/cl-symbols.lisp +++ b/cl-symbols.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: cl-symbols.lisp,v 1.3 2002/10/10 16:23:48 kevin Exp $ +;;;; $Id: cl-symbols.lisp,v 1.4 2002/12/13 21:59:57 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -42,3 +42,32 @@ (fboundp sym)) (push sym funcs)))) (nreverse funcs))) + +;;; Symbol functions + +(defun concat-symbol-pkg (pkg &rest args) + (declare (dynamic-extent args)) + (flet ((stringify (arg) + (etypecase arg + (string + (string-upcase arg)) + (symbol + (symbol-name arg))))) + (let ((str (apply #'concatenate 'string (mapcar #'stringify args)))) + (intern #-case-sensitive (string-upcase str) + #+case-sensitive str + (if pkg pkg *package*))))) + + +(defun concat-symbol (&rest args) + (apply #'concat-symbol-pkg nil args)) + +(defun ensure-keyword (name) + "Returns keyword for a name" + (etypecase name + (keyword name) + (string (values (intern + #-case-sensitive (string-upcase name) + #+case-sensitive name + :keyword))) + (symbol (values (intern (symbol-name name)) :keyword)))) diff --git a/console.lisp b/console.lisp new file mode 100644 index 0000000..3e81b23 --- /dev/null +++ b/console.lisp @@ -0,0 +1,51 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: console.lisp +;;;; Purpose: Console interactiion +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: console.lisp,v 1.1 2002/12/13 21:59:57 kevin Exp $ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by onShore Development, Inc. +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + +(defvar *console-msgs* t) + +(defvar *console-msgs-types* nil) + +(defun cmsg (template &rest args) + "Format output to console" + (when *console-msgs* + (setq template (concatenate 'string "~&;; " template "~%")) + (apply #'format t template args)) + (values)) + +(defun cmsg-c (condition template &rest args) + "Push CONDITION keywords into *console-msgs-types* to print console msgs + for that CONDITION. TEMPLATE and ARGS function identically to + (format t TEMPLATE ARGS) " + (when (or (member :verbose *console-msgs-types*) + (member condition *console-msgs-types*)) + (apply #'cmsg template args))) + +(defun cmsg-add (condition) + (pushnew condition *console-msgs-types*)) + +(defun cmsg-remove (condition) + (setf *console-msgs-types* (remove condition *console-msgs-types*))) + +(defun fixme (template &rest args) + "Format output to console" + (setq template (concatenate 'string "~&;; ** FIXME ** " template "~%")) + (apply #'format t template args) + (values)) diff --git a/genutils.lisp b/genutils.lisp index fafc902..04678e6 100644 --- a/genutils.lisp +++ b/genutils.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: genutils.lisp,v 1.11 2002/12/04 16:49:23 kevin Exp $ +;;;; $Id: genutils.lisp,v 1.12 2002/12/13 21:59:57 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -325,15 +325,6 @@ (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 diff --git a/kmrcl.asd b/kmrcl.asd index d3c69b5..83ccb5a 100644 --- a/kmrcl.asd +++ b/kmrcl.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: kmrcl.asd,v 1.22 2002/11/25 07:45:36 kevin Exp $ +;;;; $Id: kmrcl.asd,v 1.23 2002/12/13 21:59:57 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -23,6 +23,7 @@ (pushnew :kmrcl cl:*features*)) :components ((:file "package") + (:file "console" :depends-on ("package")) (:file "genutils" :depends-on ("package")) (:file "strings" :depends-on ("package")) (:file "equal" :depends-on ("package")) diff --git a/package.lisp b/package.lisp index 757c916..b71a95d 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.15 2002/12/04 16:49:23 kevin Exp $ +;;;; $Id: package.lisp,v 1.16 2002/12/13 21:59:57 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -65,8 +65,6 @@ #:indent-spaces #:print-list #:print-rows - #:concat-symbol - #:concat-symbol-pkg #:file-subst #:stream-subst #:remove-tree-if @@ -83,7 +81,12 @@ #:in #:mean #:with-gensyms - + + ;; symbols.lisp + #:ensure-keyword + #:concat-symbol + #:concat-symbol-pkg + ;; From attrib-class.lisp #:attributes-class #:slot-attribute @@ -119,6 +122,14 @@ #:xml-tag-contents #:positions-xml-tag-contents #:xml-cdata + + ;; From console + *console-msgs* + cmsg + cmsg-c + cmsg-add + cmsg-remove + fixme )) -- 2.34.1