;;;; -*- 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)
ViewGit