package.lisp

   1 ;;; package.lisp --- Common Lisp Package definition
   2
   3 ;; Copyright (C) 2010, 2011, 2012 Didier Verna.
   4
   5 ;; Author:     Didier Verna <didier@lrde.epita.fr>
   6 ;; Maintainer: Didier Verna <didier@lrde.epita.fr>
   7
   8 ;; This file is part of Clon.
   9
  10 ;; Permission to use, copy, modify, and distribute this software for any
  11 ;; purpose with or without fee is hereby granted, provided that the above
  12 ;; copyright notice and this permission notice appear in all copies.
  13
  14 ;; THIS SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  15 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  16 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  17 ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  18 ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  19 ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21
  22
  23 ;;; Commentary:
  24
  25 ;; Contents management by FCM version 0.1.
  26
  27
  28 ;;; Code:
  29
  30 (in-package :cl-user)
  31
  32 (defpackage :com.dvlsoft.clon
  33   (:documentation "The Command-Line Options Nuker package.")
  34   (:use :cl)
  35   (:shadow :*readtable*)
  36   ;; #### PORTME.
  37   (:import-from #+sbcl  :sb-mop
  38                 #+cmu   :mop
  39                 #+ccl   :ccl
  40                 #+ecl   :clos
  41                 #+clisp :clos
  42                 #+abcl  :mop
  43                 :class-slots :slot-definition-name #-abcl :validate-superclass)
  44   (:import-from :com.dvlsoft.clon.asdf
  45     :define-constant
  46     :+release-major-level+
  47     :+release-minor-level+
  48     :+release-status+
  49     :+release-status-level+
  50     :+release-name+
  51     :version)
  52   (:export
  53     ;; From com.dvlsoft.clon.asd:
  54     :+release-major-level+
  55     :+release-minor-level+
  56     :+release-status+
  57     :+release-status-level+
  58     :+release-name+
  59     :version
  60     ;; From package.lisp:
  61     :nickname-package
  62     ;; From src/util.lisp:
  63     :exit
  64     :cmdline
  65     :dump
  66     ;; From src/text.lisp:
  67     :make-text
  68     ;; From src/options/flag.lisp:
  69     :make-flag
  70     ;; From src/options/switch.lisp:
  71     :make-switch
  72     ;; From src/options/stropt.lisp:
  73     :make-stropt
  74     ;; From src/options/lispobj.lisp:
  75     :make-lispobj
  76     ;; From src/options/path.lisp:
  77     :make-path
  78     ;; From src/options/enum.lisp:
  79     :make-enum
  80     ;; From src/options/xswitch.lisp:
  81     :make-xswitch
  82     ;; From src/group.lisp:
  83     :make-group :defgroup
  84     ;; From src/synopsis.lisp:
  85     :*default-synopsis*
  86     :make-synopsis :defsynopsis
  87     ;; From src/context.lisp:
  88     :*current-context*
  89     :make-context
  90     :with-context
  91     :progname
  92     :remainder
  93     :cmdline-options-p
  94     :cmdline-p
  95     :getopt
  96     :getopt-cmdline
  97     :multiple-value-getopt-cmdline
  98     :do-cmdline-options
  99     :help))
 100
 101
 102 (in-package :com.dvlsoft.clon)
 103
 104
 105 ;; -------------------
 106 ;; External utilities:
 107 ;; -------------------
 108
 109 (defun nickname-package (&optional (nickname :clon))
 110   "Add NICKNAME (:CLON by default) to the :COM.DVLSOFT.CLON package."
 111   (rename-package :com.dvlsoft.clon
 112                   (package-name :com.dvlsoft.clon)
 113                   (adjoin nickname (package-nicknames :com.dvlsoft.clon)
 114                           :test #'string-equal)))
 115
 116
 117 ;; -------------------
 118 ;; Internal utilities:
 119 ;; -------------------
 120
 121 (defvar *readtable* (copy-readtable)
 122   "The Clon readtable.")
 123
 124 (defun configuration (key)
 125   "Return KEY's value in the current Clon configuration."
 126   (let ((configuration
 127           (find-symbol "COM.DVLSOFT.CLON.CONFIGURATION" :cl-user)))
 128     (when (and configuration (boundp configuration))
 129       (getf (symbol-value configuration) key))))
 130
 131 ;; String concatenation
 132 ;; --------------------
 133 (defun tilde-reader (stream char)
 134   "Read a series of ~\"string\" to be concatenated together."
 135   (declare (ignore char))
 136   (flet ((read-string (&aux (string (read stream t nil t)))
 137            (check-type string string "a string")
 138            string))
 139     (apply #'concatenate 'string
 140            (read-string)
 141            (loop :while (char= (peek-char t stream nil nil t) #\~)
 142                  :do (read-char stream t nil t)
 143                  :collect (read-string)))))
 144
 145 (set-macro-character #\~ #'tilde-reader nil *readtable*)
 146
 147 ;; Emacs indentation
 148 ;; -----------------
 149 (defun clindent (symbol indent)
 150   "Set SYMBOL's indentation to INDENT in (X)Emacs.
 151 This function sets SYMBOL's common-lisp-indent-function property.
 152 If INDENT is a symbol, use its indentation definition.
 153 Otherwise, INDENT is considered as an indentation definition."
 154   (when (and (member :swank *features*)
 155              (configuration :swank-eval-in-emacs))
 156     (funcall (intern "EVAL-IN-EMACS" :swank)
 157              `(put ',symbol 'common-lisp-indent-function
 158                    ,(if (symbolp indent)
 159                         `(get ',indent 'common-lisp-indent-function)
 160                       `',indent))
 161              t)))
 162
 163 (defmacro defindent (symbol indent)
 164   "Set SYMBOL's indentation to INDENT in (X)Emacs.
 165 SYMBOL and INDENT need not be quoted.
 166 See CLINDENT for more information."
 167   `(eval-when (:compile-toplevel :execute :load-toplevel)
 168      (clindent ',symbol ',indent)))
 169
 170 (defun i-reader (stream subchar arg)
 171   "Read an argument list for the DEFINDENT macro."
 172   (declare (ignore subchar arg))
 173   (cons 'defindent (read stream)))
 174
 175 (set-dispatch-macro-character #\# #\i #'i-reader *readtable*)
 176
 177
 178 ;; ECL and CLISP do not like to see undefined reader macros in expressions
 179 ;; that belong to other compilers. For instance this will break:
 180 ;; #+ccl (#_ccl-only-function)
 181 ;; It seems to be a correct behavior (see *read-suppress* in CLHS), although
 182 ;; other implementations like SBCL and CMUCL are more gentle. The solution I
 183 ;; use is to define those reader macros to simply return nil.
 184 #+(or ecl clisp)
 185 (progn
 186
 187   (defun dummy-reader (stream subchar args)
 188     "Return nil."
 189     (declare (ignore stream subchar args))
 190     nil)
 191
 192   (set-dispatch-macro-character #\# #\_ #'dummy-reader *readtable*)
 193   (set-dispatch-macro-character #\# #\$ #'dummy-reader *readtable*))
 194
 195 (defmacro in-readtable (name)
 196   "Set the current readtable to the value of NAME::*READTABLE*."
 197   `(eval-when (:compile-toplevel :load-toplevel :execute)
 198      (setf cl:*readtable* (symbol-value (find-symbol "*READTABLE*" ,name)))))
 199
 200
 201 ;;; package.lisp ends here