├── .gitignore ├── .travis.yml ├── EXAMPLE.org ├── README.org ├── circle.yml ├── lisp-namespace.asd ├── lisp-namespace.test.asd ├── src ├── namespace-let.lisp ├── namespace.lisp └── package.lisp ├── t └── package.lisp └── testscr.ros /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | addons: 5 | apt: 6 | packages: 7 | - libc6-i386 8 | - clisp 9 | - openjdk-7-jre 10 | 11 | env: 12 | global: 13 | - PATH=~/.roswell/bin:$PATH 14 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 15 | matrix: 16 | - LISP=sbcl-bin 17 | - LISP=ccl-bin 18 | - LISP=abcl 19 | - LISP=clisp 20 | - LISP=ecl 21 | - LISP=cmucl 22 | - LISP=alisp 23 | 24 | matrix: 25 | allow_failures: 26 | - env: LISP=clisp 27 | 28 | install: 29 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh 30 | 31 | cache: 32 | directories: 33 | - $HOME/.roswell 34 | - $HOME/.config/common-lisp 35 | 36 | script: 37 | - ros testscr.ros 38 | -------------------------------------------------------------------------------- /EXAMPLE.org: -------------------------------------------------------------------------------- 1 | 2 | * DEFINE-NAMESPACE 3 | 4 | #+BEGIN_SRC lisp 5 | ;; Define a namespace. It automatically defines: 6 | ;; + symbol-test 7 | ;; + (setf symbol-test) 8 | ;; + unbound-test 9 | ;; + test-boundp 10 | (define-namespace test) 11 | ;; result type of the accessor can be added (optionally) for the increased efficiency. 12 | (define-namespace test fixnum) 13 | 14 | (setf (symbol-test 'a) 0) 15 | (print (symbol-test 'a)) ; --> 0 16 | (print (symbol-test 'b)) ; --> error: UNBOUND-TEST signalled 17 | 18 | (test-boundp 'a) ; --> t 19 | 20 | ;; flet-style lexical binding constructs specialized to that namespace 21 | (let (x) 22 | (test-let ((a 1)) 23 | (setf x 24 | (lambda () 25 | (symbol-test 'a)))) 26 | (is (= 1 (funcall x)))) 27 | 28 | ;; Expands into: 29 | ;; (PROGN 30 | ;; (LET ((#:TEMP1953 1)) 31 | ;; (DECLARE (TYPE (TEST-TYPE) #:TEMP1953)) 32 | ;; (MACROLET ((SYMBOL-TEST (&WHOLE LISP-NAMESPACE::WHOLE LISP-NAMESPACE::X) 33 | ;; (IF (EQUAL LISP-NAMESPACE::X ''A) 34 | ;; '#:TEMP1953 35 | ;; LISP-NAMESPACE::WHOLE))) 36 | ;; (PROGN (SETF X (LAMBDA () (SYMBOL-TEST 'A))))))) 37 | ;; note that the argument should be lexically identifiable. 38 | 39 | (symbol-test 'a) ; --> 0 40 | 41 | #+END_SRC 42 | 43 | * NAMESPACE-LET / NSLET 44 | 45 | #+BEGIN_SRC lisp 46 | (nslet ((#'x (y) (1+ y)) 47 | ((macro x) (y) (1+ y)) 48 | ((macro y) (y) (1+ y)) 49 | (#'x (y) (1+ y)) 50 | ((label y) (y) (y y)) 51 | ((symbol-macro sm) 0) 52 | (b 0)) 53 | (let ((b 1)) 54 | (print :x))) 55 | 56 | ;; (PROGN 57 | ;; (FLET ((X (Y) (1+ Y))) 58 | ;; (MACROLET ((X (Y) (1+ Y)) 59 | ;; (Y (Y) (1+ Y))) ; same kinds of bindings are merged 60 | ;; (FLET ((X (Y) (1+ Y))) 61 | ;; (LABELS ((Y (Y) (Y Y))) 62 | ;; (SYMBOL-MACROLET ((SM 0)) 63 | ;; (LET ((B 0)) 64 | ;; (PROGN 65 | ;; (LET ((B 1)) 66 | ;; (PRINT :X)))))))))) 67 | 68 | ;; Lexical binding 69 | (funcall 70 | (namespace-let (((test a) 1)) 71 | (lambda () 72 | (symbol-test 'a)))) ; --> 1 73 | 74 | ;; (FUNCALL 75 | ;; (PROGN 76 | ;; (LET ((#:TEMP1976 1)) 77 | ;; (MACROLET ((SYMBOL-TEST (&WHOLE WHOLE X) 78 | ;; (IF (EQUAL X ''A) 79 | ;; '#:TEMP1976 80 | ;; WHOLE))) 81 | ;; (PROGN (LAMBDA () (SYMBOL-TEST 'A))))))) 82 | 83 | #+END_SRC 84 | 85 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | [[https://travis-ci.org/guicho271828/lisp-namespace][https://travis-ci.org/guicho271828/lisp-namespace.svg?branch=master]] 3 | 4 | 5 | #+BEGIN_SRC 6 | Long time ago, in a galaxy far far away... 7 | 8 | It is a period of a civil war. Lisp-2 9 | aliens, striking from the function 10 | namespace, have fought for the 11 | design of their language against lisp-1. 12 | #+END_SRC 13 | 14 | tl;dr; → skip to API definition https://github.com/guicho271828/lisp-namespace#macro-define-namespace 15 | 16 | + update (2016/5/14) : added support for `documentation` and `describe`. 17 | + update (2016/5/21) : works on ECL, CLISP, ABCL and CMUCL. 18 | 19 | * Introduction 20 | 21 | # However, destructuring is merely 22 | # a syntax sugar for writing the accessor. 23 | 24 | There are several libraries which extends =let=. To my knowledge, 25 | most of them goes toward destructuring, e.g., allowing 26 | =&some-fancy-directive= in the argument list. However, destructuring is 27 | now **obsolete**: superseded by pattern-matching (e.g. fare-matcher, optima, trivia), which 28 | cleanly combines =cond=, =typecase=, destructuring and constructors[1]. 29 | Now it comes to my mind: what could be the *orthogonal* aspect 30 | that could be combined with =let=, or, =let + cond = pattern matching= ? 31 | 32 | Then I noticed an oddness in flet, macrolet, labels, let, 33 | symbol-macrolet. Pattern matching works in the value namespace only. 34 | # Also, 35 | # while special bindings for /namespaces/ can be trivially implemented with a 36 | # hash table, the lexical binding is not 37 | --- it's worth a library. This is 38 | what this library is for. 39 | 40 | [1] Like =(cons A B)= matching clause vs =(cons A B)= constructor. 41 | 42 | * Namespaces in CL? 43 | 44 | By /namespace/ I don't mean a /package/, 45 | which is a way to manage symbols. It is orthogonal to /namespace/. 46 | 47 | CL already has major 2 namespaces, /function/ namespace and /value/ 48 | namespace (or /variable/ namespace), but there are actually more --- e.g., 49 | /class/ namespace. Since the same symbol can represent different 50 | objects in each namespace, this is obviously orthogonal to /package/. 51 | For example, all these below can coexist in a 52 | same file without errors, and each object is accessible with the 53 | corresponding function. 54 | 55 | #+BEGIN_SRC lisp 56 | (in-package :cl-user) 57 | 58 | (defclass foo () ()) 59 | (defun foo () nil) 60 | (defvar foo 1) 61 | 62 | (find-class 'foo) ; -> # 63 | (symbol-function 'foo) ; -> # 64 | (symbol-value 'foo) ; -> 1 65 | 66 | (make-instance 'bar) ; -> SIMPLE-ERROR 67 | (symbol-function 'bar) ; -> UNDEFINED-FUNCTION 68 | (symbol-value 'bar) ; -> UNBOUND-VARIABLE 69 | #+END_SRC 70 | 71 | | namespace | accessor | unbound condition | boundp | binding | 72 | |-----------+-----------------+--------------------+---------+-------------| 73 | | class | find-class | SIMPLE-ERROR | n/a | n/a | 74 | | function | symbol-function | UNDEFINED-FUNCTION | fboundp | flet,labels | 75 | | value | symbol-value | UNBOUND-VARIABLE | boundp | let | 76 | 77 | /Some/ namespaces in CL can be said to overlap with each other. For example: 78 | 79 | + *class* namespace --- with *type*, *condition* and *struct* namespace 80 | + *function* namspace --- with *macro-function* and *generic-function* namespace 81 | + *value* namespace --- with *symbol-macro* namespace. 82 | 83 | ** Macro DEFINE-NAMESPACE 84 | 85 | : (define-namespace name &optional (expected-type t) (binding t) (documentation "")) 86 | 87 | This macro defines a namespace. For the given name of namespace X, 88 | DEFINE-NAMESPACE defines 4 functions/macros: 89 | 90 | + =#'symbol-x, #'(setf symbol-x)= : accessor to the global binding. Optionally, 91 | =expected-type= provides =ftype= proclamation and results in the 92 | better optimization. =expected-type= is not evaluated. 93 | + =#'x-boundp= : unary function returning a boolean 94 | + condition =UNBOUND-X= which is signaled when trying to access the value of an unbounded symbol. 95 | + macro =(X-LET (binding...) body)= : lexical binding. Can be turned off 96 | when =binding= is nil. 97 | 98 | ** Extending the usability of =documentation= and =describe= 99 | 100 | =define-namespace= also defines a method for =cl:documentation= and extend =cl:describe-object=. For example, you will be able to =(setf (documentation 'mysymbol 'x) "description")= and you will see it pretty printed in =(describe 'mysymbol)=. 101 | 102 | Here is an example used in TRIVIA pattern matcher. Trivia has an =assoc= pattern, and everyone would feel happy if we can browse the documentation of this pattern from SLIME C-c C-d. Below is such an output on SBCL. 103 | 104 | While such a practice is taken by some libraries (e.g. QL-HTTP and Stefil defines =describe= methods), those facility is made independently, and this feature is not much popular. 105 | 106 | #+begin_src diff 107 | COMMON-LISP:ASSOC 108 | [symbol] 109 | 110 | ASSOC names a compiled function: 111 | Lambda-list: (ITEM ALIST &KEY KEY (TEST NIL TESTP) 112 | (TEST-NOT NIL NOTP)) 113 | Declared type: (FUNCTION 114 | (T LIST &KEY (:KEY (OR FUNCTION SYMBOL)) 115 | (:TEST (OR FUNCTION SYMBOL)) 116 | (:TEST-NOT (OR FUNCTION SYMBOL))) 117 | (VALUES LIST &OPTIONAL)) 118 | Documentation: 119 | Return the cons in ALIST whose car is equal (by a given test or EQL) to 120 | the ITEM. 121 | Known attributes: call, foldable, flushable, unsafely-flushable 122 | Source file: SYS:SRC;CODE;LIST.LISP 123 | 124 | +Symbol ASSOC is bound in a namespace PATTERN: 125 | + Value: # 126 | + Documentation: 127 | + It matches when the object X is a list, and then further matches the contents 128 | + returned by (cdr (assoc item X...)) against SUBPATTERN. 129 | + If :KEY and :TEST is specified, they are passed to ASSOC. 130 | #+end_src 131 | 132 | Note that /namespace/ itself has its own namespace. The optional argument =documentation= to =define-namespace= is a docstring of the namespace itself. It will be set to =(setf (documentation NAME 'namespace) documentation)= and will also be visible from =describe=. 133 | 134 | Examples are in [[EXAMPLE.org]] . 135 | 136 | * Expected Usecase? 137 | 138 | Every time you want to define a =define-cool-object= macro. E.g., 139 | 140 | + in [[https://github.com/guicho271828/eazy-project][eazy-project]], [[https://github.com/guicho271828/eazy-project/blob/master/src/defmenu.lisp#L24][defmenu]] 141 | + in [[https://github.com/AccelerationNet/function-cache][function-cache]], [[https://github.com/AccelerationNet/function-cache/blob/master/src/cache.lisp#L4][defcached]] (currently implemented with hash tables) 142 | + in [[https://github.com/m2ym/optima][optima]], [[https://github.com/m2ym/optima/blob/master/src/pattern.lisp#L337][defpattern and pattern-expand-function]] (currently implemented 143 | with symbol properties) 144 | + in [[https://github.com/Bike/compiler-macro][compiler-macro]], [[https://github.com/Bike/compiler-macro/blob/master/hint.lisp#L10][define-compiler-hinter]] (currently implemented with hash tables) 145 | + in [[https://github.com/cffi/cffi][cffi]], [[https://github.com/cffi/cffi/blob/master/src/libraries.lisp#L129][define-foreign-library]] (currently implemented with hash tables) 146 | 147 | * Other misc 148 | 149 | ** Macro NAMESPACE-LET / NSLET 150 | 151 | =LET= with ability to lexically bind any value in the namespace. 152 | It currently supports /function, labels, value, symbol-macro, macrolet, 153 | restart, handler/ [2] namespaces and the user-defined namespaces. 154 | 155 | Full examples are in [[EXAMPLE.org]] . 156 | 157 | #+BEGIN_SRC lisp 158 | (namespace-let ((#'x (y) (1+ y)) 159 | ((macro x) (y) (1+ y)) 160 | ((macro y) (y) (1+ y)) 161 | (#'x (y) (1+ y)) 162 | ((label y) (y) (y y)) 163 | ((symbol-macro sm) 0) 164 | (b 0)) 165 | (let ((b 1)) 166 | (print :x))) 167 | 168 | ;; (PROGN 169 | ;; (FLET ((X (Y) (1+ Y))) 170 | ;; (MACROLET ((X (Y) (1+ Y)) 171 | ;; (Y (Y) (1+ Y))) ; same kinds of bindings are merged 172 | ;; (FLET ((X (Y) (1+ Y))) 173 | ;; (LABELS ((Y (Y) (Y Y))) 174 | ;; (SYMBOL-MACROLET ((SM 0)) 175 | ;; (LET ((B 0)) 176 | ;; (PROGN 177 | ;; (LET ((B 1)) 178 | ;; (PRINT :X)))))))))) 179 | #+END_SRC 180 | 181 | [2] restarts and handlers have the dynamic scope only. 182 | 183 | ** Package LISP-NAMESPACE 184 | 185 | it has =(:nicknames lispn)= . 186 | 187 | 188 | 189 | * Design? 190 | 191 | I'm wondering which abbreviation to =namespace-let= is appropriate. 192 | It should be something consistent with the historic name as =let=. 193 | However, I do not like names like =let+= because they are not 194 | self-expressive --- =let+= does not describe how it's different from the 195 | original =let=. =bind= and =where= are not considered good either, due to the 196 | similar reason. 197 | 198 | I adopted =nslet=, thanks to masatoi0@twitter's 199 | advice. However, there is another alternative: Make it =let= and force the 200 | user to shadow =cl:let=? (nah I don't like it.) I'm still searching for a 201 | crazy bright idea. 202 | 203 | Here are the remaining TODOs: 204 | 205 | + X-let does not recognize =(declare (special ...))= currently. 206 | 207 | * Dependencies 208 | 209 | This library is at least tested on implementation listed below: 210 | 211 | + SBCL 1.2.8 on X86 Linux 3.13.0-44-generic (author's environment) 212 | + CCL 1.10-r16196 (LinuxX8664) 213 | 214 | Also, it depends on the following libraries: 215 | 216 | + alexandria by ** : 217 | Alexandria is a collection of portable public domain utilities. 218 | 219 | 220 | * Author & Copyright 221 | 222 | Copyright (c) 2015 Masataro Asai (guicho2.71828@gmail.com) 223 | 224 | Licensed under the LLGPL License. 225 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | environment: 3 | PATH: ~/.roswell/bin:$PATH 4 | 5 | dependencies: 6 | pre: 7 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/master/scripts/install-for-ci.sh | sh 8 | - ros install ccl-bin 9 | - ros install clisp 10 | - ros install abcl-bin 11 | - ros install ecl 12 | - ros install cmu-bin 13 | cache_directories: 14 | - ~/.roswell/ 15 | 16 | test: 17 | override: 18 | - ros -L sbcl-bin testscr.ros 19 | - ros -L ccl-bin testscr.ros 20 | - ros -L clisp testscr.ros 21 | - ros -L ecl testscr.ros 22 | - ros -L abcl-bin testscr.ros 23 | - ros -L cmu-bin testscr.ros 24 | -------------------------------------------------------------------------------- /lisp-namespace.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of lisp-namespace project. 3 | Copyright (c) 2015 Masataro Asai (guicho2.71828@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Masataro Asai (guicho2.71828@gmail.com) 8 | |# 9 | 10 | 11 | 12 | (in-package :cl-user) 13 | (defpackage lisp-namespace-asd 14 | (:use :cl :asdf)) 15 | (in-package :lisp-namespace-asd) 16 | 17 | 18 | (defsystem lisp-namespace 19 | :version "0.1" 20 | :author "Masataro Asai" 21 | #+asdf3 :mailto #+asdf3 "guicho2.71828@gmail.com" 22 | :license "LLGPL" 23 | :depends-on (:alexandria) 24 | :components ((:module "src" 25 | :components 26 | ((:file "package") 27 | (:file "namespace") 28 | (:file "namespace-let")) 29 | :serial t)) 30 | :description "Provides LISP-N --- extensible namespaces in Common Lisp." 31 | :in-order-to ((test-op (test-op lisp-namespace.test)))) 32 | -------------------------------------------------------------------------------- /lisp-namespace.test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of lisp-namespace project. 3 | Copyright (c) 2015 Masataro Asai (guicho2.71828@gmail.com) 4 | |# 5 | 6 | 7 | (in-package :cl-user) 8 | (defpackage lisp-namespace.test-asd 9 | (:use :cl :asdf)) 10 | (in-package :lisp-namespace.test-asd) 11 | 12 | 13 | (defsystem lisp-namespace.test 14 | :author "Masataro Asai" 15 | #+asdf3 :mailto #+asdf3 "guicho2.71828@gmail.com" 16 | :description "test system for lisp-namespace" 17 | :license "LLGPL" 18 | :depends-on (:lisp-namespace :uiop :fiveam) 19 | :components ((:module "t" 20 | :components 21 | ((:file "package")) 22 | :serial t)) 23 | :perform (test-op :after (op c) 24 | (eval (read-from-string "(5am:run! :lisp-namespace)")) 25 | (asdf:clear-system c))) 26 | -------------------------------------------------------------------------------- /src/namespace-let.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :lispn) 3 | 4 | ;; TODO namespace-let 5 | 6 | ;; renaming candidate: 7 | ;; namespace-let 8 | ;; where --- eazy to type in, but incosistent with common lisp 9 | ;; bind --- I dont think it is cool, similar reason to where 10 | ;; overwriting cl:let --- well, maybe optional 11 | 12 | (defmacro namespace-let (bindings &body body) 13 | "Bindings is a list of bindings where each car is of form (NAMESPACE NAME), 14 | or a symbol NAME for a variable namespace. 15 | 16 | function, macro, label, symbol-macro, handler, restart is by default recognized as a namespace. 17 | 18 | Example: 19 | (namespace-let ((#'x (y) (1+ y)) ; -- equivalent to ((function x) (y) (1+ y)) 20 | ((macro x) (y) (1+ y)) 21 | ((macro y) (y) (1+ y)) 22 | (#'x (y) (1+ y)) 23 | ((label y) (y) (y y)) 24 | ((symbol-macro sm) 0) 25 | (b 0)) 26 | (let ((b 1)) 27 | (print :x))) 28 | " 29 | (%pickone (reverse bindings) `((progn ,@body)))) 30 | 31 | (setf (macro-function 'nslet) 32 | (macro-function 'namespace-let)) 33 | 34 | ;; mutual recursion 35 | 36 | (defun %pickone (bindings body) 37 | (if bindings 38 | (destructuring-bind ((specifier &rest definition) &rest rest) bindings 39 | (cond 40 | ((listp specifier) 41 | (destructuring-bind (namespace name) specifier 42 | (case namespace 43 | ;; function-like binding 44 | (function 45 | (%merge 'flet name definition body rest)) 46 | (label 47 | (%merge 'labels name definition body rest)) 48 | (macro 49 | (%merge 'macrolet name definition body rest)) 50 | ;; variable-like binding 51 | (symbol-macro 52 | (%merge 'symbol-macrolet name definition body rest)) 53 | ;; handler binding 54 | (handler 55 | (%merge 'handler-bind name definition body rest)) 56 | (restart 57 | (%merge 'restart-bind name definition body rest)) 58 | (otherwise 59 | (if (namespace-boundp namespace) 60 | (%pickone rest (%wrap namespace name definition body)) 61 | (error "unknown namespace ~a !" namespace)))))) 62 | ((symbolp specifier) 63 | (%merge 'let specifier definition body rest)))) 64 | `(progn ,@body))) 65 | 66 | (defun %merge (kind name def body rest) 67 | (%pickone 68 | rest 69 | (handler-case 70 | (destructuring-bind ((kind2 bindings &rest newbody)) body 71 | (assert (eq kind kind2)) 72 | `((,kind ((,name ,@def) ,@bindings) ,@newbody))) 73 | (error () 74 | `((,kind ((,name ,@def)) ,@body)))))) 75 | 76 | (defun %wrap (namespace name definition body) 77 | (with-slots (accessor type) (symbol-namespace namespace) 78 | (with-gensyms (temp) 79 | `((let ((,temp ,@definition)) 80 | (declare (type (,type) ,temp)) 81 | (macrolet ((,accessor (&whole whole x) 82 | (if (equal x '(quote ,name)) 83 | ',temp 84 | whole))) 85 | ,@body)))))) 86 | 87 | ;; lexical nickname for packages : abondoned 88 | 89 | #+nil 90 | (defun %bind-package (def body rest-bindings) 91 | ;; This one is special. All symbols are interned in the current package at 92 | ;; the read time, but this binder parse them again, then intern in the 93 | ;; target package. 94 | ;; Also, it runs in compile-time, not in runtime. Therefore, the target 95 | ;; package should also exist in compile-time. 96 | (assert (find-package def) nil 97 | "The specified package ~a should exist in compilation time!" def) 98 | (let ((pkg (find-package def))) 99 | (%pickone 100 | rest-bindings 101 | (maptree (lambda (s) 102 | (match s 103 | ((symbol name) 104 | (intern name pkg)) 105 | (_ s))) 106 | body)))) 107 | 108 | #+nil 109 | (defun maptree (fn tree) 110 | (match tree 111 | ((cons car cdr) 112 | (cons (maptree fn car) 113 | (maptree fn cdr))) 114 | ((type array) 115 | (let ((a (copy-array tree))) 116 | (dotimes (i (array-total-size a) a) 117 | (setf (row-major-aref a i) 118 | (funcall fn (row-major-aref tree i)))))) 119 | (_ (funcall fn tree)))) 120 | 121 | #+nil 122 | (maptree #'print '(let (x y) 123 | (test-let ((a 1)) 124 | (setf x (lambda () (symbol-test 'a))) 125 | (test-let ((a 2)) 126 | (setf y (lambda () (symbol-test 'a))))) 127 | (is (= 1 (funcall x))) 128 | (is (= 2 (funcall y))))) 129 | #+nil 130 | (maptree #'print #(a b c d e)) 131 | #+nil 132 | (maptree #'print #2a((a b c d e))) 133 | #+nil 134 | (read-from-string "`(a ,b)") 135 | 136 | -------------------------------------------------------------------------------- /src/namespace.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lispn) 2 | 3 | (define-namespace namespace %namespace nil "A namespace for managing namespaces themselves.") 4 | 5 | (defun clear-namespace (name) 6 | "Get rid of all values bound in the given namespaces." 7 | (assert (gethash name *namespace-table*)) 8 | (clrhash (symbol-value (%namespace-hash (gethash name *namespace-table*)))) 9 | name) 10 | 11 | #+clisp 12 | (format *error-output* "On CLISP, we cannot add method to DESCRIBE-OBJECT, so you cannot enjoy extended documentations for various namespaces") 13 | #+lispworks 14 | (format *error-output* "On Lispworks, we cannot add method to DESCRIBE-OBJECT, so you cannot enjoy extended documentations for various namespaces") 15 | 16 | #-(or clisp lispworks) ;; Lispworks complains about redefining existing describe-object method. Let's continue. 17 | (defmethod describe-object :after ((x symbol) s) 18 | (let ((*print-pretty* t)) 19 | (pprint-logical-block (s nil) 20 | (maphash (lambda (name ns) 21 | (when (funcall (%namespace-boundp ns) x) 22 | (pprint-logical-block (s nil) 23 | (format s "~@:_Symbol ~S is bound in a namespace ~S:" x name) 24 | (pprint-indent :block 2 s) 25 | (format s "~@:_Value: ~S" (funcall (%namespace-accessor ns) x)) 26 | (if-let ((doc (documentation x name))) 27 | (progn 28 | (format s "~@:_Documentation: ~@:_") 29 | (pprint-logical-block (s nil :per-line-prefix " ") 30 | (princ doc s))) 31 | (format s "~@:_(undocumented)"))))) 32 | *namespace-table*)))) 33 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :lisp-namespace 3 | (:use :cl :alexandria) 4 | (:nicknames :lispn) 5 | (:export :define-namespace 6 | :clear-namespace 7 | :namespace-let 8 | :nslet) 9 | (:documentation " 10 | This package provides a method to define additional namespaces for lisp. 11 | 12 | Common lisp is lisp-2, which means it has a different namespaces for the 13 | value and the function. With lisp-namespace, you can define arbitrary additional 14 | namespaces and its accessors as well. 15 | 16 | The idea is simple. Common lisp has `symbol-value' and `symbol-function', 17 | so I added `symbol-anything-you-like'. Current implementation is 18 | built on a hashtable. 19 | ")) 20 | 21 | (in-package :lispn) 22 | 23 | ;; patch for Allegro CL Modern Mode 24 | ;; https://franz.com/support/documentation/current/doc/case.htm#modern-mode-1 25 | (defun keep-upcase-or-preserve (str) 26 | (if (eq :UPCASE (readtable-case *readtable*)) 27 | str 28 | (string-downcase str))) 29 | 30 | ;; the name of this variable shoud not be changed, to maintain consistency 31 | ;; to the hash tables defined by define-namespace. 32 | (defvar *namespace-hash* (make-hash-table :test 'eq)) 33 | (defstruct (%namespace 34 | (:constructor %namespace 35 | (name 36 | &aux 37 | (accessor (symbolicate (keep-upcase-or-preserve "SYMBOL-") name)) 38 | (hash (symbolicate "*" name (keep-upcase-or-preserve "-TABLE*"))) 39 | (condition (symbolicate (keep-upcase-or-preserve "UNBOUND-") name)) 40 | (boundp (symbolicate name (keep-upcase-or-preserve "-BOUNDP"))) 41 | (type (symbolicate name (keep-upcase-or-preserve "-TYPE"))) 42 | (letname (symbolicate name (keep-upcase-or-preserve "-LET"))) 43 | (doc-table (symbolicate "*" name (keep-upcase-or-preserve "-DOC-TABLE*")))))) 44 | (name (error "anonymous namespace?") :type symbol :read-only t) 45 | (accessor nil :type symbol :read-only t) 46 | (hash nil :type symbol :read-only t) ;; default values are fed by the constructor above 47 | (condition nil :type symbol :read-only t) 48 | (boundp nil :type symbol :read-only t) 49 | (type nil :type symbol :read-only t) 50 | (letname nil :type symbol :read-only t) 51 | (doc-table nil :type symbol :read-only t)) 52 | (defmethod make-load-form ((ns %namespace) &optional environment) 53 | (make-load-form-saving-slots ns :environment environment)) 54 | (defmethod print-object ((ns %namespace) s) 55 | (pprint-logical-block (s nil :prefix "#S(" :suffix ")") 56 | (prin1 '%namespace s) 57 | (write-char #\Space s) 58 | (pprint-logical-block (s nil) 59 | (format s "~{~s ~s~^~:@_~}" 60 | (with-slots (name accessor hash condition boundp type letname doc-table) ns 61 | `(:name ',name 62 | :accessor ',accessor 63 | :hash ',hash 64 | :condition ',condition 65 | :boundp ',boundp 66 | :type ',type 67 | :letname ',letname 68 | :doc-table ',doc-table)))))) 69 | 70 | (defmacro define-namespace (name &optional 71 | (expected-type t) 72 | (namespace-let t) 73 | (documentation "")) 74 | "This macro defines a namespace. For the given name of namespace X, 75 | DEFINE-NAMESPACE defines 4 functions/macros: 76 | 77 | + #'SYMBOL-X, #'(setf SYMBOL-X) : accessor to the global binding. Optionally, 78 | EXPECTED-TYPE provides FTYPE proclamation and results in the 79 | better optimization. EXPECTED-TYPE is not evaluated. 80 | + #'X-BOUNDP : unary function returning a boolean 81 | + condition UNBOUND-X which is signaled when trying to access the value of an unbounded symbol. 82 | + macro (X-LET (binding...) body) : lexical binding. It is defined when BINDING is non-nil. " 83 | (when (member name '(function 84 | macrolet 85 | name 86 | package 87 | plist 88 | value)) 89 | (error "~a cannot be used as a namespace because it conflicts with the standard Common Lisp!" 90 | name)) 91 | (let ((ns (%namespace name))) 92 | (with-slots (accessor hash condition boundp letname type doc-table) ns 93 | `(eval-when (:compile-toplevel :load-toplevel :execute) 94 | (defvar ,hash (make-hash-table :test 'eq)) 95 | (defvar ,doc-table (make-hash-table :test 'eq)) 96 | (define-condition ,condition (unbound-variable) () 97 | (:report (lambda (c s) (format s "Symbol ~a is unbound in namespace ~a" 98 | (cell-error-name c) ',name)))) 99 | (deftype ,type () ',expected-type) 100 | (declaim (ftype (function (symbol &optional (or null ,type)) 101 | (values ,type &optional)) 102 | ,accessor) 103 | (ftype (function ((,type) symbol) (,type)) (setf ,accessor)) 104 | (inline ,accessor) 105 | (inline (setf ,accessor))) 106 | (defun (setf ,accessor) (new-value symbol) 107 | "Automatically defined setter function." 108 | (setf (gethash symbol ,hash) new-value)) 109 | (defun ,accessor (symbol &optional (default nil default-supplied-p)) 110 | "Automatically defined getter function. When DEFAULT is supplied, the value is set automatically." 111 | (multiple-value-bind (value found) 112 | (gethash symbol ,hash) 113 | (if found value 114 | (if default-supplied-p 115 | (setf (,accessor symbol) default) 116 | (restart-case 117 | (error ',condition :name symbol) 118 | (use-value (default) 119 | (setf (,accessor symbol) default))))))) 120 | (defun ,boundp (symbol) 121 | "Automatically defined boolean function." 122 | (nth-value 1 (gethash symbol ,hash))) 123 | ,@(when namespace-let 124 | `((defmacro ,letname (bindings &body body) 125 | `(namespace-let 126 | ,(mapcar (lambda (bind) `((,',name ,(car bind)) ,@(cdr bind))) 127 | bindings) 128 | ,@body)))) 129 | (setf (gethash ',name *namespace-table*) ,ns) 130 | (defmethod documentation ((x symbol) (type (eql ',name))) 131 | (gethash x ,doc-table)) 132 | (defmethod (setf documentation) (newdoc (x symbol) (type (eql ',name))) 133 | (setf (gethash x ,doc-table) newdoc)) 134 | (setf (documentation ',name 'namespace) ,documentation))))) 135 | 136 | -------------------------------------------------------------------------------- /t/package.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of lisp-namespace project. 3 | Copyright (c) 2015 Masataro Asai (guicho2.71828@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage :lisp-namespace.test 8 | (:use :cl 9 | :lisp-namespace 10 | :fiveam) 11 | (:export :mytest 12 | :symbol-mytest 13 | :unbound-mytest 14 | :mytest-let)) 15 | (in-package :lisp-namespace.test) 16 | 17 | 18 | 19 | (def-suite :lisp-namespace) 20 | (in-suite :lisp-namespace) 21 | 22 | ;; run test with (run! test-name) 23 | ;; test as you like ... 24 | 25 | (test let 26 | ;; it may not signal error. 27 | #+nil 28 | (signals error 29 | (eval 30 | '(let ((b 0) 31 | (b 1)) 32 | (print :x)))) 33 | ;; does not merge (b 0) and (b 1) 34 | (finishes 35 | (namespace-let ((b 0)) 36 | (let ((b 1)) 37 | (print :x))))) 38 | 39 | (test complicated 40 | (finishes 41 | `(namespace-let ((#'x (y) (1+ y)) 42 | ((macro x) (y) (1+ y)) 43 | ((macro y) (y) (1+ y)) 44 | ((label z) (y) (w y)) 45 | ((label w) (y) (z y)) 46 | ((macro y) (y) (1+ y)) 47 | ((symbol-macro sm) 0) 48 | (b 0)) 49 | (let ((b 1)) 50 | (print :x))))) 51 | 52 | (test restart 53 | (finishes 54 | (namespace-let (((restart continue) 55 | (lambda (c) 56 | (declare (ignore c)) 57 | (print :hi!)))) 58 | (let ((b 1)) 59 | (print :x))))) 60 | 61 | (define-namespace mytest fixnum) 62 | 63 | (test namespace 64 | (finishes 65 | (setf (symbol-mytest 'a) 0)) 66 | (is (= (symbol-mytest 'a))) 67 | (signals unbound-mytest 68 | (symbol-mytest 'b)) 69 | ;; lexical 70 | (is (= 1 71 | (funcall 72 | (namespace-let (((mytest a) 1)) 73 | (lambda () 74 | (symbol-mytest 'a)))))) 75 | (let (x) 76 | (namespace-let (((mytest a) 1)) 77 | (setf x 78 | (lambda () 79 | (symbol-mytest 'a)))) 80 | (is (= 1 (funcall x)))) 81 | ;; lexical, specialized 82 | (let (x) 83 | (mytest-let ((a 1)) 84 | (setf x 85 | (lambda () 86 | (symbol-mytest 'a)))) 87 | (is (= 1 (funcall x)))) 88 | 89 | ;; nested 90 | (let (x y) 91 | (mytest-let ((a 1)) 92 | (setf x (lambda () (symbol-mytest 'a))) 93 | (mytest-let ((a 2)) 94 | (setf y (lambda () (symbol-mytest 'a))))) 95 | (is (= 1 (funcall x))) 96 | (is (= 2 (funcall y)))) 97 | (finishes 98 | (describe 'mytest))) 99 | 100 | (defpackage :other-package 101 | (:use :cl :lisp-namespace :fiveam :lisp-namespace.test)) 102 | 103 | (test export 104 | (in-package :other-package) 105 | (eval 106 | (read-from-string 107 | (princ-to-string 108 | '(progn 109 | (finishes 110 | (setf (symbol-mytest 'a) 0)) 111 | (is (= 0 (symbol-mytest 'a))) 112 | (signals unbound-mytest 113 | (symbol-mytest 'b)) 114 | ;; lexical 115 | (is (= 1 116 | (funcall 117 | (namespace-let (((mytest a) 1)) 118 | (lambda () 119 | (symbol-mytest 'a)))))) 120 | (let (x) 121 | (namespace-let (((mytest a) 1)) 122 | (setf x 123 | (lambda () 124 | (symbol-mytest 'a)))) 125 | (is (= 1 (funcall x)))) 126 | ;; lexical, specialized 127 | (let (x) 128 | (mytest-let ((a 1)) 129 | (setf x 130 | (lambda () 131 | (symbol-mytest 'a)))) 132 | (is (= 1 (funcall x)))) 133 | 134 | ;; nested 135 | (let (x y) 136 | (mytest-let ((a 1)) 137 | (setf x (lambda () (symbol-mytest 'a))) 138 | (mytest-let ((a 2)) 139 | (setf y (lambda () (symbol-mytest 'a))))) 140 | (is (= 1 (funcall x))) 141 | (is (= 2 (funcall y))))))))) 142 | -------------------------------------------------------------------------------- /testscr.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (ql:quickload :uiop) 8 | (ql:quickload :fiveam) 9 | 10 | (defun test (sys &optional (tsys sys)) 11 | (handler-case 12 | (progn 13 | (ql:quickload tsys) 14 | (fiveam:run sys)) 15 | (serious-condition (c) 16 | (describe c) 17 | (uiop:quit 2)))) 18 | 19 | (defun main (&rest argv) 20 | (declare (ignorable argv)) 21 | (uiop:quit (if (every #'fiveam::TEST-PASSED-P 22 | (test :lisp-namespace :lisp-namespace.test)) 23 | 0 1))) 24 | --------------------------------------------------------------------------------