;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: environment.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Lisp OS Environments.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2013-11-30 <PJB> Added this header.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2013
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.ENVIRONMENT"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE")
(:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.PACKAGE"
. ("SYMBOL"
"SYMBOLP" "MAKE-SYMBOL" "SYMBOL-NAME" "SYMBOL-PACKAGE"
"SYMBOL-VALUE" "SYMBOL-FUNCTION" "SYMBOL-PLIST"
"BOUNDP" "FBOUNDP"
"KEYWORD" "KEYWORDP"
"PACKAGE"
"PACKAGEP" "MAKE-PACKAGE" "FIND-PACKAGE" "DELETE-PACKAGE"
"FIND-SYMBOL" "IMPORT" "INTERN" "SHADOW" "SHADOWING-IMPORT"
"EXPORT" "UNEXPORT" "UNINTERN" "USE-PACKAGE"
"UNUSE-PACKAGE" "PACKAGE-NAME" "PACKAGE-NICKNAMES"
"PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST" "PACKAGE-SHADOWING-SYMBOLS"
"LIST-ALL-PACKAGES" "FIND-ALL-SYMBOLS" "RENAME-PACKAGE"
"*PACKAGE*"
"WITH-PACKAGE-ITERATOR"
"DO-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-ALL-SYMBOLS"
"DEFPACKAGE" "IN-PACKAGE"
"PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE"))
(:export "FIND-ENVIRONMENT" "FIND-PACKAGE" "FIND-SYMBOL"
"UPDATE-READTABLE"
"*ENVIRONMENT*")
(:documentation "
Author: Pascal J. Bourguignon <pjb@informatimago.com>
Copyright: 2013 Pascal J. Bourguignon
License: AGPL3
"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.ENVIRONMENT")
#|
Provisional syntax
=======================
To help with experiments and discussions, I would like to establish
the following syntaxes to name environments, and packages and symbols
within environments.
ENVNAME:::PACKAGE:SYMBOL
reads as the symbol PACKAGE:SYMBOL in the environment ENVNAME.
It should be equivalent to reading:
PACKAGE:SYMBOL
when the ENVIRONMENT package is the system environment package,
and ENVIRONMENT:*ENVIRONMENT* is bound to the non-NIL result of
(ENVIRONMENT:FIND-ENVIRONMENT "ENVNAME")
The symbol should be exported from the package, otherwise a "no
such external symbol" error should occur.
But as long as the readtable used to read it
(ie. COMMON-LISP:*READTABLE*, in the current environment
ENVIRONMENT:*ENVIRONMENT*) allows reading this syntax,
ENVNAME:::PACKAGE:SYMBOL reads as the denoted symbol even if the
system environment package is not available in the current
environment.
ENVNAME, PACKAGE and SYMBOL are read subject to the current
readtable case and escape mechanisms.
Note: considering that an environment could contain a different
lisp than COMMON-LISP, perhaps we could ignore the external symbol
constraint, and consider this syntax to be equivalent to the
following.
ENVNAME:::PACKAGE::SYMBOL
reads as the symbol PACKAGE::SYMBOL in the environment ENVNAME.
Similar discussion as above, only the symbol doesn't needs to be
exported.
ENVNAME:::THING
ENVNAME::::THING
Invalid read syntax.
I find no obviously clear rule about what package to find the
symbols in, given that an environment may not contain the
COMMON-LISP package.
#E"ENVNAME"
reads as the result of:
(or (environment:find-environment "ENVNAME")
(error "No such environment"))
even when the system environment package is not available in the
current environment, as logn as current the readtable provides
this reader dispatching macro.
#E"ENVNAME:::PACKAGE"
reads as the result of:
(or (environment:find-package
"PACKAGE"
(or (environment:find-environment "ENVNAME")
(error "No such environment")))
(error "No such package"))
even when the system environment package is not available in the
current environment, as logn as current the readtable provides
this reader dispatching macro.
#E"ENVNAME:::PACKAGE::SYMBOL"
reads as the result of:
(or (environment:find-symbol
"SYMBOL"
(or (environment:find-package
"PACKAGE"
(or (environment:find-environment "ENVNAME")
(error "No such environment")))
(error "No such package")))
(error "No such symbol"))
even when the system environment package is not available in the
current environment, as long as current the readtable provides
this reader dispatching macro.
Note: ENVIRONMENT:FIND-SYMBOL, ENVIRONMENT:FIND-PACKAGE and
ENVIRONMENT:FIND-ENVIRONMENT return NIL when no object with the
given name exist, like COMMON-LISP:FIND-SYMBOL and
COMMON-LISP:FIND-PACKAGE do.
Informally, ENVNAME::: can be used to designate the #E"ENVNAME"
environment and ENVNAME:::PACKAGE can be used to designate the
#E"ENVNAME:::PACKAGE" package, but since COMMON-LISP packages don't
have a reader syntax, we don't implement one for ENVNAME:::PACKAGE.
Given the (current?) rejection of ENVNAME:::THING and
ENVNAME::::THING, it would be possible to use ":" (or "::") instead of
":::" to separate the environment name from the package name:
ENV:PKG:ESYM
ENV:PKG::ISYM
by avoiding the informal ENVNAME::: and ENVNAME:::PACKAGE.
But I feel it safer to establish the use of ::: for environments,
since implementations could provide a semantic for A:B:C or A::B::C.
|#
#|
(coerce (loop for i from 32 to 126 collect (code-char i)) 'string)
" !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
"\\"
"|"
":"
(specials "!$%&*+-./<=>?@[]^_{}~")
(letters "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
(digits "0123456789")
(initial (or letters specials))
(follow (or letters digits specials))
(initial (rep follow) ":::" )
environment:*environment*
sysenv
|#
;;; Utilities
(deftype string-designator () (or string symbol character))
(deftype package-designator () (or package string symbol))
(defun map-into-hash-table (sequence &key
(key (function identity))
(value (function identity))
(test (function eql))
(size nil sizep)
(rehash-size nil rehash-size-p)
(rehash-threshold nil rehash-threshold-p))
"
Creates a new hash-table, filled with the associations obtained by
applying the function KEY and the function VALUE on each element of
the SEQUENCE.
The other key parameter are passed to MAKE-HASH-TABLE.
"
(let ((table (apply (function make-hash-table)
:test test
(append (when sizep
(list :size size))
(when rehash-size-p
(list :rehash-size rehash-size))
(when rehash-threshold-p
(list :rehash-threshold rehash-threshold))))))
(map nil (lambda (element)
(setf (gethash (funcall key element) table) (funcall value element)))
sequence)
table))
;;; Environment
(defvar *environment-counter* 0)
(defclass environment ()
((name :initarg :name
:initform (error "An environment must have a name")
:reader environment-name)
(parent :initarg :parent
:initform nil
:reader environment-parent
:documentation "The parent environment, for sub-environments.")
(environments :initarg :environments
:initform nil
:type (or null hash-table)
:reader environment-environments
:documentation "Children or sub- environments.")
(packages :initarg :packages
:initform (make-hash-table :test (function equal))
:reader environment-packages)
#+not-implemented-yet
(special-bindings :initarg :special-bindings
:initform (make-hash-table :test (function eq))
:reader environment-special-bindings
:documentation "Global dynamic bindings.")
#+not-implemented-yet
(lexical-bindings :initarg :lexical-bindings
:initform (make-hash-table :test (function eq))
:reader environment-lexical-bindings
:documentation "Global lexical bindings such as symbol-macros.")
#+not-implemented-yet
(function-bindings :initarg :function-bindings
:initform (make-hash-table :test (function eq))
:reader environment-function-bindings
:documentation "Function, macros, special operators.")))
(defmethod copy-environment ((original environment) name &key
(parent (environment-parent original))
(deep-copy-environments nil)
(deep-copy-packages nil))
"
Create a new environment named NAME which must be unique amongst the
sub-environments of the PARENT.
If DEEP-COPY-ENVIRONMENTS is true, then also recursively make copies
of the sub-environments.
If DEEP-COPY-PACKAGES is true, then copy the packages, else import
them into the new environment.
"
(check-type name string)
(check-type parent environment)
(assert (not (find-environment name parent)) ()
"The name of the new environment ~S must be unique amongst ~S"
name (mapcar (function environment-name) (environment-children parent)))
(let ((copy (make-instance 'environment
:name name
:parent parent
:environments (if deep-copy-environments
(copy-package-table (environment-packages original))
(copy-hash-table (environment-packages original)))
:packages (if deep-copy-packages
(copy-package-table (environment-packages original))
(copy-hash-table (environment-packages original))))))
copy))
(defvar *private-packages* '()
"A list of low-level packages that should be hidden from the environments.")
(defvar *root-environment*
(make-instance 'environment
:name ""
:packages (map-into-hash-table (set-difference (copy-list (cl:list-all-packages)) *private-packages*)
:test (function equal)
:key (function package-name)
:value (function identity))))
(defvar *environment*
(copy-environment :name "ROOT"
:parent *root-environment*
:deep-copy-environments t
:deep-copy-packages t))
(defun find-environment (name &optional (parent *environment*))
(check-type name string-designator)
(check-type parent environment)
(and (environment-environments parent)
(gethash (string name) (environment-environments parent))))
(defun find-package (name &optional (parent *environment*))
(check-type name string-designator)
(check-type parent environment)
(and (environment-packages parent)
(gethash (string name) (environment-packages parent))))
(defun find-symbol (name &optional package)
(let ((package (or package
(and (find-package "COMMON-LISP")
(find-symbol "*PACKAGE*" (find-package "COMMON-LISP"))
(symbol-value (find-symbol "*PACKAGE*" (find-package "COMMON-LISP")))))))
(check-type name string-designator)
(check-type parent package)
(cl:find-symbol (string name) package)))
;; It'll be easier with an environment:package class wrapping cl:package.
(defun delete-package (pkg)
(check-type pkg package-designator)
)
(defun package-name (package)
)
#|
abc:::def:ghi
abc:::def::ghi
|abc def|:::def:ghi
abc\ def:::ghi:jkl
123abc:::def:ghi
|#