;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: virtual-cl.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; This package creates a new set of packages CL, KEYWORD and
;;;; CL-USER, the CL package exporting symbols with the same name
;;;; and bindings as the COMMON-LISP package, with the required
;;;; operators overriden to protect the COMMON-LISP and KEYWORD
;;;; packages, and avoid any side-band channel.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2013-12-14 <PJB> Created.
;;;;BUGS
;;;; Plenty. You don't imagine I get this right from the start, do you?
;;;;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.VIRTUAL-CL"
(:use "COMMON-LISP"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.LISPOS.VIRTUAL-CL")
(defun compute-cl-clone-name (base-name)
(loop
:for i :from 0
:for name = (concatenate 'string base-name ".CL")
:then (format nil "~A.~A.CL" base-name i)
:while (find-package name)
:finally (return name)))
(defun clone-common-lisp-package (base-name)
(let* ((name (compute-cl-clone-name base-name))
(clone (make-package name :use '() :nicknames '()))
(exports '()))
(do-external-symbols (sym "COMMON-LISP")
(let ((cloned-sym (intern (symbol-name sym) clone)))))
(export exports clone)
clone))
"
Basically two choices to virtualize symbols:
- substitute them: intern a different symbol with the same name, and
the same (or a variant of the) bindings.
Consequences:
+ any binding (package, value, function, macro,
symbo-macro, plist, etc) are strictly local
- the symbol cannot be used by identity by the system CL package,
or its original cannot be used by identity by the virtual
environment.
- import the original symbol.
Consequences:
- the original bindings are present, they may have to be protected,
overriding (symbol-package symbol-value symbol-function
macro-function macroexpand macroexpand-1 symbol-plist) etc.
+ they can be used for identity: keywords, T, NIL,
lambda-list-keywords, restarts.
"
(defparameter *symbol-categories*
'(
(declarations (:by-identity :used-by-cl :returned-by-cl) "
Declaration symbols are present in program sources, and also as data,
when passed to PROCLAIM. They can be present in sexps returned by
eg. FUNCTION-LAMBDA-EXPRESSION (and perhaps in some slot of error
condition).
If we substitute them we must be extra careful their originals are not
leaked back.
"
DECLARATION DYNAMIC-EXTENT FTYPE IGNORABLE IGNORE INLINE NOTINLINE
OPTIMIZE SPECIAL TYPE)
(compound-type-specifier (:for-identity :used-by-cl :returned-by-cl) "
For all type and class specifiers, if we have type objects, like for
classes, and a function that would give back a type specifier in the
current environment we can recover type specifiers specific to each
environment. (There would still be a problem when type specifiers
themselves would be communicated from one environment to the other).
With substitution (satisfies sym) should not get out of CL.
With import, (satisfies sym) should be ok.
In both cases: Can we ensure that giving to CL a value that is of type
\(satisfies private-predicate) can't leak the symbol private-predicate
to another environment? Ie, type-of never returns a satisfies
compound-type-specifier?
"
and or not eql member array simple-array vector simple-vector
bit-vector simple-bit-vector string base-string simple-string
simple-base-string real complex float short-float single-float
double-float long-float rational integer signed-byte
unsigned-byte mod function cons values satisfies)
(type (:for-identity :used-by-cl :returned-by-cl)
EXTENDED-CHAR BASE-CHAR STANDARD-CHAR BASE-STRING SIMPLE-STRING
SIMPLE-BASE-STRING FIXNUM BIGNUM SIGNED-BYTE UNSIGNED-BYTE BIT
SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT COMPILED-FUNCTION
SIMPLE-ARRAY SIMPLE-VECTOR SIMPLE-BIT-VECTOR NIL)
(class (:for-identity :used-by-cl :returned-by-cl)
STANDARD-OBJECT STRUCTURE-OBJECT)
(system-class (:for-identity :used-by-cl :returned-by-cl)
t array method number stream symbol package restart function
pathname sequence character readtable hash-table random-state
method-combination vector string bit-vector list cons
built-in-class standard-class structure-class generic-function
standard-generic-function standard-method real complex float
rational ratio integer logical-pathname class echo-stream
file-stream string-stream synonym-stream two-way-stream
broadcast-stream concatenated-stream null)
(condition-type (:for-identity :used-by-cl :returned-by-cl) "
Actually, the condition objects can be the same, only the symbols
naming their type/class and their reader functions, or their bindings,
change from one implementation to the other.
In both cases, (and similarly for other types and classes), there may
be a need for reverse mapping of object type to symbols in environment
naming them..
Careful with leaks:
(setf (symbol-plist 'zz) '(some important data 42))
(setf (symbol-plist 'tt) '(some other secret data))
(error 'type-error :datum 'zz 'expected-type 'tt)
"
condition serious-condition simple-condition warning
storage-condition error arithmetic-error cell-error control-error
file-error package-error parse-error print-not-readable
program-error stream-error type-error division-by-zero
floating-point-inexact floating-point-invalid-operation
floating-point-overflow floating-point-underflow unbound-slot
unbound-variable undefined-function reader-error simple-error
simple-type-error simple-warning end-of-file style-warning)
(symbol (:for-identity :used-by-cl :returned-by-cl) "
function-lambda-expression
"
declare lambda)
(lambda-list-keyword (:for-identity :used-by-cl :returned-by-cl) "
function-lambda-expression
"
&optional &rest &aux &key &allow-other-keys &body &environment
&whole)
(variable (:for-value :used-by-cl :returned-by-cl) "
Dynamic bindings go in both directions.
"
*package* ; environment specific packages
*readtable* ; environment specific reader macros
*debugger-hook* ; we may have to provide an environment specific debugger wrapper
*break-on-signals*
;; streams
*standard-input* *standard-output* *query-io* *terminal-io* *trace-output*
*debug-io* *error-output*
;; compile-file and load dynamic variables
*compile-file-pathname*
*compile-file-truename*
*load-pathname* *load-truename*
;; compile and load variables
*compile-print* *compile-verbose*
*load-print* *load-verbose*
;; Misc
*macroexpand-hook*
*features*
*random-state*
*default-pathname-defaults*
*gensym-counter*
*modules*
;; printer variables
*print-array* *print-base* *print-case*
*print-circle* *print-escape* *print-gensym* *print-length*
*print-level* *print-lines* *print-miser-width*
*print-pprint-dispatch* *print-pretty* *print-radix*
*print-readably* *print-right-margin*
;; reader variables
*read-base* *read-default-float-format* *read-eval* *read-suppress*
;; repl variables
- / // /// * ** *** + ++ +++)
(constant-variable (:for-value
:for-identity :used-by-cl :returned-by-cl #|t nil|#) "
Most constants could be substituted, but NIL and T which should be
self-valued like keywords.
"
nil t ; self bound!
pi array-dimension-limit array-rank-limit
array-total-size-limit boole-1 boole-2 boole-andc1 boole-andc2
boole-and boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand
boole-nor boole-orc1 boole-orc2 boole-set boole-xor
call-arguments-limit char-code-limit double-float-epsilon
double-float-negative-epsilon internal-time-units-per-second
lambda-list-keywords lambda-parameters-limit
least-negative-double-float least-negative-long-float
least-negative-normalized-double-float
least-negative-normalized-long-float
least-negative-normalized-short-float
least-negative-normalized-single-float least-negative-short-float
least-negative-single-float least-positive-double-float
least-positive-long-float least-positive-normalized-double-float
least-positive-normalized-long-float
least-positive-normalized-short-float
least-positive-normalized-single-float least-positive-short-float
least-positive-single-float long-float-epsilon
long-float-negative-epsilon most-negative-double-float
most-negative-fixnum most-negative-long-float
most-negative-short-float most-negative-single-float
most-positive-double-float most-positive-fixnum
most-positive-long-float most-positive-short-float
most-positive-single-float multiple-values-limit short-float-epsilon
short-float-negative-epsilon single-float-epsilon
single-float-negative-epsilon)
(accessor (:for-function :for-setf) "
cf. SETF, define-setf-expander, etc.
- problem of (setf gethash) et al. which have no public operator:
public operators have to be provided to hide the original ones.
"
;; symbols (and function designators, and classes)
symbol-function symbol-plist symbol-value get
compiler-macro-function macro-function fdefinition
find-class
;; conses
caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar
caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr
cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr first second
third fourth fifth sixth seventh eighth ninth tenth rest nth
getf
;; sequences
elt subseq
;; hash tables
gethash
;; arrays
aref row-major-aref bit sbit svref char schar fill-pointer
;; numbers
ldb mask-field
;; pathnames
logical-pathname-translations
;; readtable
readtable-case
;; Miscellaneous
values)
(function (:for-function) "
Seems easy to deal with functions by subtitution.
However:
- some function symbols have other bindings that are not so easy to
deal by substitution.
- each function input and output and exceptional situations need to be
detailed and controlled:
- package functions -> new package system
- symbol functions -> wrapping?
- type functions? (pjb.cl:typep 42 'pjb.cl:integer)
- etc.
"
;; predicate
atom constantp eq eql equal equalp
;; numbers
1- 1+ abs acos acosh ash asin
asinh atan atanh
ceiling cis
complex complexp conjugate
cos cosh decode-float denominator
;; restarts
abort
compute-restarts
continue
find-restart
;; conditions
error
;; sequences
concatenate copy-seq
count count-if count-if-not
delete-duplicates
delete delete-if delete-if-not
fill find find-if find-if-not
;; conses
acons adjoin assoc assoc-if assoc-if-not
append
butlast
cons consp
copy-alist copy-list copy-tree
;; arrays
adjustable-array-p adjust-array
array-dimension array-dimensions array-displacement
array-element-type array-has-fill-pointer-p array-in-bounds-p
arrayp array-rank array-row-major-index array-total-size
bit-andc1
bit-andc2 bit-and bit-eqv bit-ior bit-nand bit-nor bit-not
bit-orc1 bit-orc2 bit-vector-p bit-xor
;; characters
alpha-char-p alphanumericp
both-case-p
character characterp
char-code char-downcase char-equal char<= char< char= char>=
char> char/= char-greaterp char-int char-lessp char-name
char-not-equal char-not-greaterp char-not-lessp char-upcase
code-char digit-char digit-char-p
;; symbols
boundp
;; functions
apply compiled-function-p complement constantly disassemble
ensure-generic-function
;; misc
apropos apropos-list
describe
;; conditions
arithmetic-error-operands arithmetic-error-operation
cell-error-name cerror
break
;; boolean functions
boole
;; byte
byte byte-position byte-size
deposit-field
;; file (pathname)
dribble
delete-file
directory directory-namestring
ensure-directories-exist
enough-namestring
file-author
file-error-pathname file-length file-namestring file-position
file-string-length file-write-date
;; stream
broadcast-stream-streams
clear-input clear-output close
concatenated-stream-streams
echo-stream-input-stream echo-stream-output-stream
finish-output
class-of
clrhash
coerce
compile-file compile-file-pathname compile
copy-pprint-dispatch
copy-readtable
copy-structure
copy-symbol
delete-package
export
find-package
decode-universal-time
get-decoded-time get-internal-real-time get-internal-run-time
dpb
ed
endp
eval
evenp
fboundp fmakunbound
find-all-symbols
find-symbol
gensym gentemp
every
exp expt fceiling ffloor float-digits float floatp float-precision
float-radix float-sign floor fround ftruncate gcd
<= < = >= > - /= / * +
force-output format
fresh-line
funcall
function-lambda-expression functionp
get-dispatch-macro-character
get-macro-character
get-output-stream-string get-properties get-setf-expansion
get-universal-time graphic-char-p hash-table-count hash-table-p
hash-table-rehash-size hash-table-rehash-threshold
hash-table-size hash-table-test host-namestring identity imagpart
import input-stream-p inspect integer-decode-float integer-length
integerp interactive-stream-p intern intersection
invalid-method-error invoke-debugger invoke-restart
invoke-restart-interactively isqrt keywordp last lcm ldb-test
ldiff length lisp-implementation-type lisp-implementation-version
list-all-packages listen list list* list-length listp load
load-logical-pathname-translations logandc1 logandc2 logand
logbitp logcount logeqv log logical-pathname logior lognand
lognor lognot logorc1 logorc2 logtest logxor long-site-name
lower-case-p machine-instance machine-type machine-version
macroexpand-1 macroexpand make-array make-broadcast-stream
make-concatenated-stream make-condition
make-dispatch-macro-character make-echo-stream make-hash-table
make-list make-load-form-saving-slots make-package make-pathname
make-random-state make-sequence make-string
make-string-input-stream make-string-output-stream make-symbol
make-synonym-stream make-two-way-stream makunbound mapcan mapcar
mapc mapcon map maphash map-into mapl maplist max member
member-if member-if-not merge merge-pathnames
method-combination-error min minusp mismatch mod muffle-warning
name-char namestring nbutlast nconc nintersection notany notevery
not nreconc nreverse nset-difference nset-exclusive-or
nstring-capitalize nstring-downcase nstring-upcase nsublis nsubst
nsubst-if nsubst-if-not nsubstitute nsubstitute-if
nsubstitute-if-not nthcdr null numberp numerator nunion oddp open
open-stream-p output-stream-p package-error-package package-name
package-nicknames packagep package-shadowing-symbols
package-used-by-list package-use-list pairlis parse-integer
parse-namestring pathname-device pathname-directory pathname
pathname-host pathname-match-p pathname-name pathnamep
pathname-type pathname-version peek-char phase plusp position
position-if position-if-not pprint-dispatch pprint-fill pprint
pprint-indent pprint-linear pprint-newline pprint-tab
pprint-tabular prin1 prin1-to-string princ princ-to-string print
print-not-readable-object probe-file proclaim provide random
random-state-p rassoc rassoc-if rassoc-if-not rational
rationalize rationalp read-byte read-char read-char-no-hang
read-delimited-list read-from-string read read-line
read-preserving-whitespace read-sequence readtablep realpart
realp reduce rem remhash remove-duplicates remove remove-if
remove-if-not remprop rename-file rename-package replace require
restart-name revappend reverse room round rplaca rplacd
scale-float search set-difference set-dispatch-macro-character
set-exclusive-or set set-macro-character set-pprint-dispatch
set-syntax-from-char shadow shadowing-import short-site-name
signal signum simple-bit-vector-p
simple-condition-format-arguments simple-condition-format-control
simple-string-p simple-vector-p sin sinh sleep slot-boundp
slot-exists-p slot-makunbound slot-value software-type
software-version some sort special-operator-p sqrt stable-sort
standard-char-p store-value stream-element-type
stream-error-stream stream-external-format streamp
string-capitalize string-downcase string-equal string<= string<
string= string>= string> string string/= string-greaterp
string-left-trim string-lessp string-not-equal
string-not-greaterp string-not-lessp stringp string-right-trim
string-trim string-upcase sublis subsetp subst subst-if
subst-if-not substitute substitute-if substitute-if-not subtypep
sxhash symbol-name symbol-package symbolp synonym-stream-symbol
tailp tan tanh terpri translate-logical-pathname
translate-pathname tree-equal truename truncate
two-way-stream-input-stream two-way-stream-output-stream
type-error-datum type-error-expected-type type-of typep
unbound-slot-instance unexport unintern union unread-char
unuse-package upgraded-array-element-type
upgraded-complex-part-type upper-case-p use-package
user-homedir-pathname use-value values-list vector vectorp
vector-pop vector-push-extend vector-push warn wild-pathname-p
write-byte write-char write write-line write-sequence
write-string write-to-string yes-or-no-p y-or-n-p zerop)
(local-function (:for-function) "
Local functions are provided by macros, so refer to them.
"
CALL-NEXT-METHOD NEXT-METHOD-P)
(local-macro (:for-macro) "
Local macros are provided by macros, so refer to them.
"
CALL-METHOD LOOP-FINISH MAKE-METHOD PPRINT-EXIT-IF-LIST-EXHAUSTED
PPRINT-POP)
(macro (:for-macro)
"
Basically, macros can be substituted by new macros, expanding to our
functions and special operators, with minimum difficulties.
However:
- we may lose implementation features (eg. atomicity of incf),
- we still may have to deal with the used symbols (special variables,
keywords, etc).
- there's the case of SETF.
"
and assert case ccase check-type cond ctypecase decf declaim
defclass defconstant defgeneric define-compiler-macro
define-condition define-method-combination define-modify-macro
define-setf-expander define-symbol-macro defmacro defmethod
defpackage defparameter defsetf defstruct deftype defun defvar
destructuring-bind do-all-symbols do-external-symbols dolist do
do* do-symbols dotimes ecase etypecase formatter handler-bind
handler-case ignore-errors incf in-package lambda loop
multiple-value-bind multiple-value-list multiple-value-setq
nth-value or pop pprint-logical-block print-unreadable-object
prog1 prog2 prog prog* psetf psetq push pushnew remf
restart-bind restart-case return rotatef setf shiftf step time
trace typecase unless untrace when with-accessors
with-compilation-unit with-condition-restarts
with-hash-table-iterator with-input-from-string with-open-stream
with-output-to-string with-package-iterator with-simple-restart
with-slots with-standard-io-syntax)
(restart (:for-identity :used-by-cl :returned-by-cl) "
Used by the debugger, restart handing, with-simple-restart, etc.
With substitution, we would need to substitute the original restarts
to avoid leaking
With import, there are fbindings..
"
ABORT CONTINUE MUFFLE-WARNING STORE-VALUE USE-VALUE)
(special-operator (:for-identity :used-by-cl) "
They could be substituted by macros, but the expansions should not
leak system symbols…
"
block catch eval-when flet function go if labels let let*
load-time-value locally macrolet multiple-value-call
multiple-value-prog1 progn progv quote return-from setq
symbol-macrolet tagbody the throw unwind-protect)
(standard-generic-function (:for-function) "
If we import them, there may be methods bound for classes,
condition-types, and system-classes. Those methods may have to be
replaced. MOP may help in finding an exhaustive list of methods.
With substitution, we start with clean generic functions.
"
add-method allocate-instance change-class class-name
compute-applicable-methods describe-object documentation
find-method
;; find-method works on the classes (and objects), not on the class names.
;; Therefore there's no need to put the methods "bindings" in the environment.
function-keywords initialize-instance
make-instances-obsolete make-instance make-load-form
method-qualifiers no-applicable-method no-next-method print-object
reinitialize-instance remove-method shared-initialize slot-missing
slot-unbound update-instance-for-different-class
update-instance-for-redefined-class)))
;; (mapcar 'first *symbol-categories*)
;;
;; (declarations compound-type-specifier type class system-class
;; condition-type symbol lambda-list-keyword variable constant-variable
;; accessor function local-function local-macro macro restart
;; special-operator standard-generic-function)
;; Some keywords are used by CL operators, eg :key :test :test-not
;; :documentation, etc.
;;
;;
;; clall -r '(let (r) (do-symbols (s "KEYWORD") (pushnew s r)) (length (sort r (function string<))))'
;;
;; Armed Bear Common Lisp --> 242
;; Clozure Common Lisp --> 1969
;; CLISP --> 1195
;; CMU Common Lisp --> 1867
;; SBCL --> 1788
;;;
;;; TYPES
;;;
'(compound-type-specifier (:for-identity :used-by-cl :returned-by-cl) "
With substitution (satisfies sym) should not get out of CL.
With import, (satisfies sym) should be ok.
In both cases: Can we ensure that giving to CL a value that is of type
\(satisfies private-predicate) can't leak the symbol private-predicate
to another environment? Ie, type-of never returns a satisfies
compound-type-specifier?
"
;; compound types
and or not
;; can leak symbols and objects.
eql member satisfies
function values
;; cons = array type
cons
;; array types: array simple-array vector simple-vector
bit-vector simple-bit-vector string base-string simple-string
simple-base-string
;; number types:
real complex float short-float single-float double-float
long-float rational integer signed-byte unsigned-byte mod )
'(type (:for-identity :used-by-cl :returned-by-cl)
;; function
COMPILED-FUNCTION
;; empty type
NIL
;; characters
EXTENDED-CHAR BASE-CHAR STANDARD-CHAR
;; arrays
BASE-STRING SIMPLE-STRING SIMPLE-BASE-STRING
SIMPLE-ARRAY SIMPLE-VECTOR SIMPLE-BIT-VECTOR
;; numbers
FIXNUM BIGNUM SIGNED-BYTE UNSIGNED-BYTE BIT
SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
'(class (:for-identity :used-by-cl :returned-by-cl)
STANDARD-OBJECT STRUCTURE-OBJECT)
'(system-class (:for-identity :used-by-cl :returned-by-cl)
;; everything
t
;; careful with debugging, backtraces, etc.
restart
;; file system
pathname
logical-pathname
;; file system
stream
file-stream
;; other streams
echo-stream
string-stream
synonym-stream
two-way-stream
broadcast-stream
concatenated-stream
;; packages & symbols
package symbol null
;; classes
class built-in-class standard-class structure-class
;; functions & methods
readtable ; function-like with all the reader macros.
function generic-function standard-generic-function
method method-combination standard-method
;; collections
sequence hash-table
;; cons ⚠ list covers the symbol CL:NIL
list cons
;; arrays
array vector string bit-vector
;; basically like a number, but mutable
random-state
;; characters
character
;; numbers
number real complex float rational ratio integer
)
'(condition-type (:for-identity :used-by-cl :returned-by-cl)
condition serious-condition simple-condition warning
storage-condition error arithmetic-error cell-error control-error
file-error package-error parse-error print-not-readable
program-error stream-error type-error division-by-zero
floating-point-inexact floating-point-invalid-operation
floating-point-overflow floating-point-underflow unbound-slot
unbound-variable undefined-function reader-error simple-error
simple-type-error simple-warning end-of-file style-warning)