-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ParenScript package system
-
-(in-package :parenscript)
-
-(defclass script-package ()
- ;; configuration slots
- ((name :accessor script-package-name :initform nil :initarg :name :type string
- :documentation "Canonical name of the package (a String).")
- (nicknames :accessor script-package-nicknames :initform nil :initarg :nicknames
- :documentation "List of nicknames for the package (as strings).")
- (prefix :accessor script-package-prefix :initform nil :initarg :prefix :type string
- :documentation "The prefix string that will be used when translating the symbols in the current package to Javascript.")
- (lisp-package :accessor script-package-lisp-package :initform nil :initarg :lisp-package)
- (secondary-lisp-packages :accessor script-package-secondary-lisp-packages :initform nil
- :initarg :secondary-lisp-packages)
- (exports :accessor script-package-exports :initarg :exports
- :initform nil;(make-hash-table :test #'equal)
- :documentation "List of exported identifiers.")
- (used-packages :accessor script-package-used-packages :initform nil :initarg :used-packages
- :documentation "")
- (documentation :accessor script-package-documentation :initform nil :initarg :documentation)
- (compilation-env :accessor script-package-comp-env :initform nil :initarg :comp-env)
- (locked? :accessor script-package-locked? :initform nil :initarg :locked?
- :documentation "t if redefinition of top-level symbols is disallowed.")
- ;; internal use slots
- (symbol-table :accessor script-package-symbol-table :initform nil :initarg :symbol-table
- :documentation "Contains symbols when there is no lisp package for this package.")
- )
- (:documentation "A Parenscript package is a lisp object that holds information
-about a set of code.
-
-"))
-
-(defmethod print-object ((sp script-package) stream)
- (format stream "#<SCRIPT-PACKAGE ~s>" (script-package-name sp)))
-
-(defclass compilation-environment ()
- ((script-packages :accessor comp-env-script-packages :initform nil :initarg :packages
- :documentation "List of packages defined in this environment.")
- (current-package :accessor comp-env-current-package :initform nil :initarg :current-package
- :documentation "Current in-package.")
- (lisp-to-script-package-table
- :accessor comp-env-lisp-to-script-package-table :initform (make-hash-table)
- :documentation "Maps a lisp package to a script package.")
- (compiling-toplevel-p
- :accessor comp-env-compiling-toplevel-p :initform nil :initarg :processing-toplevel-p
- :documentation "T if the environment is currently processing toplevel forms.")
- (symbol-table :accessor symbol-to-script-package :initform (make-hash-table)
- :documentation "Maps symbols to script packages. Used for only the
-symbols in script packages that do not have a primary lisp package."))
- (:documentation ""))
-
-(defgeneric symbol-script-package (symbol)
- (:documentation "Gets the Parenscript package associated with a Lisp/Parenscript symbol."))
-
-(defvar *warn-ps-package* nil
- "If true, warns when ParenScript attempts to compile symbols that
-don't have an associated ParenScript package.")
-
-(defun lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*))
- "Gets a script package corresponding to the given Lisp package."
- (gethash lisp-package (comp-env-lisp-to-script-package-table comp-env)))
-
-(defsetf lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*))
- (script-package)
- "Sets the script package corresponding to the given Lisp package."
- `(setf (gethash ,lisp-package (comp-env-lisp-to-script-package-table ,comp-env))
- ,script-package))
-
-(defmethod symbol-script-package ((symbol symbol))
- (if (symbol-package symbol)
- (or (lisp-to-script-package (symbol-package symbol) *compilation-environment*)
- (progn (when *warn-ps-package*
- (warn 'simple-style-warning
- :format-control "~s is a symbol with lisp package ~s, which has no corresponding ParenScript package.
-Defaulting to :parenscript-user."
- :format-arguments (list symbol (symbol-package symbol))))
- (find-script-package "PARENSCRIPT-USER" (make-basic-compilation-environment))))
- (find-script-package "UNINTERNED" *compilation-environment*)))
-
-(defun find-script-package (name &optional (comp-env *compilation-environment*))
- "Find the script package with the name NAME in the given compilation environment."
- (typecase name
- ((or symbol string)
- (find-if #'(lambda (script-package)
- (find (string name)
- (cons (script-package-name script-package)
- (script-package-nicknames script-package))
- :test #'equal))
- (comp-env-script-packages comp-env)))
- (script-package name)
- (t (error "~A has unknown type" name))))
-
-(defun script-intern (name script-package-name)
- "Returns a Parenscript symbol with the string value STRING interned for the
-given SCRIPT-PACKAGE."
- (declare (type string name))
- (let ((script-package (find-script-package script-package-name)))
- (flet ((find-exported-symbol (name script-package)
- (let ((res
- (find name (script-package-exports script-package)
- :key #'(lambda (exported-symbol) (string exported-symbol))
- :test #'equal)))
- res)))
- (let ((res
- (or
- (some #'(lambda (used-package)
- (find-exported-symbol name used-package))
- (script-package-used-packages script-package))
- (if (script-package-lisp-package script-package)
- (intern name (script-package-lisp-package script-package))
- (progn
- (let ((sym (intern-without-package name)))
- (setf (gethash name (script-package-symbol-table script-package))
- sym)
- (setf (gethash sym (symbol-to-script-package (script-package-comp-env script-package)))
- script-package)
- sym))))))
- (declare (type symbol res))
- res))))
-
-(defun find-script-symbol (name script-package)
- "Finds the symbol with name NAME in the script package SCRIPT-PACKAGE. NAME is a
-string and SCRIPT-PACKAGE is a package designator. If NAME does not specify a symbol of
-script-package, returns nil. Otherwise returns 2 values:
-1. the symbol
-2. :external if the symbol is external. :internal if the symbol is internal. NIL if
-the symbol is not interned in the package."
- (setf script-package (find-script-package script-package))
- (let (symbol interned-p)
-
- (if (script-package-lisp-package script-package)
- (multiple-value-bind (lisp-symbol lisp-status)
- (find-symbol name (script-package-lisp-package script-package))
- (setf symbol lisp-symbol)
- (setf interned-p (and lisp-status t)))
- (multiple-value-bind (sym sym-found-p)
- (gethash name (script-package-symbol-table script-package))
- (setf symbol sym)
- (setf interned-p sym-found-p)))
- (let ((exported? (member symbol (script-package-exports script-package))))
- (values symbol
- (if exported? :external (if interned-p :internal nil))))))
-
-(defun script-export (symbols
- &optional (script-package (comp-env-current-package *compilation-environment*)))
- "Exports the given symbols in the given script package."
- (when (not (listp symbols)) (setf symbols (list symbols)))
- (setf script-package (find-script-package script-package))
- (let ((symbols-not-in-package
- (remove-if #'(lambda (symbol)
- (declare (type symbol symbol))
- (eql symbol (find-script-symbol (string symbol) script-package)))
- symbols)))
- (when symbols-not-in-package
- (error "Invalid exports. The following symbols are not interned in the package ~A:~%~A"
- (script-package-name script-package) symbols-not-in-package)))
- (mapc #'(lambda (symbol)
- (pushnew symbol (script-package-exports script-package)))
- symbols)
- t)
-
-(defun use-script-package (packages-to-use
- &optional (into-package (comp-env-current-package *compilation-environment*)))
- "use-script-package causes INTO-PACKAGE to inherit all the external symbols of packages-to-use.
-The inherited symbols become accessible as internal symbols of package."
- (when (not (listp packages-to-use)) (setf packages-to-use (list packages-to-use)))
- (setf packages-to-use (mapcar #'find-script-package packages-to-use))
- (setf into-package (find-script-package into-package))
-
- (let ((all-used-symbols (apply #'append (mapcar #'script-package-exports packages-to-use))))
- (mapc #'(lambda (used-symbol)
- (let ((symbol-same-name (find-script-symbol (string used-symbol) into-package)))
- (when (not (or (null symbol-same-name)
- (eql symbol-same-name used-symbol)))
- (error "Import of symbol ~A into package ~A conflicts with interned symbol ~A"
- used-symbol (script-package-name into-package) symbol-same-name))))
- all-used-symbols))
- (setf (script-package-used-packages into-package)
- (append (script-package-used-packages into-package) packages-to-use)))
-
-(defun intern-without-package (name)
- (macrolet ((with-temp-package ((var) &body body)
- (let ((result-var (gensym)))
- `(let* ((,var (make-package ',(gensym)))
- (,result-var (progn ,@body)))
- (delete-package ,var)
- ,result-var))))
- (with-temp-package (package)
- (let ((sym (intern name package)))
- (unintern sym package)
- sym))))
-
-(defun create-script-package (comp-env
- &key name nicknames prefix secondary-lisp-packages used-packages
- lisp-package exports documentation)
- "Creates a script package in the given compilation environment"
- (when (and lisp-package (not (find-package lisp-package)))
- (error "Package ~A does not exists" lisp-package))
- (let* ((script-package
- (make-instance 'script-package
- :name (string name)
- :comp-env comp-env
- :prefix prefix
- :nicknames (mapcar #'string nicknames)
- :lisp-package (when lisp-package (find-package lisp-package))
- :secondary-lisp-packages (mapcar #'find-package secondary-lisp-packages)
- :documentation documentation)))
- (use-script-package used-packages script-package)
- (labels ((package-intern (string-like)
- (script-intern (string string-like) script-package)))
- (script-export (mapcar #'package-intern exports) script-package))
- (push script-package (comp-env-script-packages comp-env))
- script-package))
-
-(defmethod initialize-instance :after ((package script-package) &key)
- (assert (script-package-comp-env package))
- (when (null (script-package-lisp-package package))
- (setf (script-package-symbol-table package)
- (make-hash-table :test #'equal)))
- (let ((lisp-packages
- (remove-if #'null
- (cons (script-package-lisp-package package)
- (script-package-secondary-lisp-packages package)))))
- (dolist (lisp-package lisp-packages)
- (when (lisp-to-script-package lisp-package (script-package-comp-env package))
- (error "Lisp package already has corresponding script package: ~A" (package-name lisp-package)))
- (setf (lisp-to-script-package lisp-package (script-package-comp-env package))
- package))))
-
-(defgeneric comp-env-find-package (comp-env package-designator)
- (:documentation "Finds the script package named by PACKAGE-DESIGNATOR in the current
-compilation environment. PACKAGE-DESIGNATOR is a string or symbol.")
- (:method ((comp-env compilation-environment) (name string))
- (find name (comp-env-script-packages comp-env)
- :key #'script-package-name :test #'equal))
- (:method ((comp-env compilation-environment) (package-designator symbol))
- (comp-env-find-package comp-env (string package-designator))))
-
-;; TODO loop through all defined macros and add them to the script package's
-;; macro environment
-; (labels ((name-member (name)
-; (eql (script-package-lisp-package script-package) (symbol-package name)))
-; (import-macro (name function)
-; (when (name-member name)
-; (setf (gethash name (script-package-macro-table script-package))
-; function)))
-; (import-special-form (name function)
-; (when (name-member name)
-; (setf (gethash name (script-package-special-form-table script-package))
-; function))))
-; (maphash #'import-special-form *toplevel-special-forms*)
-; (maphash #'import-special-form *toplevel-special-forms*)
-
-;(defgeneric comp-env-select-package (comp-env script-package)
-; (:documentation "")
-; (:method ((comp-env compilation-environment) (package script-package))
-; (setf (comp-env-current-package
-
-
-(defvar *enable-package-system* nil)
-
-;;; Interface for reading in identifier
-
-(defgeneric lisp-symbol-to-ps-identifier (symbol context &optional compilation-environment)
- (:documentation "Context is one of :special-form, :macro or nil."))
-
-(defmethod lisp-symbol-to-ps-identifier ((symbol symbol) (context (eql :special-form)) &optional comp-ev)
- (declare (ignore context comp-ev))
- (symbol-name symbol))
-
-(defmethod lisp-symbol-to-ps-identifier ((symbol symbol) (context (eql :macro)) &optional comp-ev)
- (declare (ignore context comp-ev))
- symbol)
-
-(defmethod lisp-symbol-to-ps-identifier :around ((symbol symbol) context &optional comp-ev)
- (declare (ignore context comp-ev))
- (if *enable-package-system*
- (call-next-method)
- (symbol-name symbol)))
-
-;;; Symbol obfuscation (this should really go somewhere else)
-(defvar *obfuscate-standard-identifiers* nil)
-
-(defparameter *obfuscation-table* (make-hash-table))
-
-(defun obfuscated-symbol (symbol)
- (or (gethash symbol *obfuscation-table*)
- (setf (gethash symbol *obfuscation-table*) (string (gensym)))))
-
-;;; Interface for printing identifiers
-
-(defvar *package-prefix-style* :prefix
- "Determines how package symbols are serialized to JavaScript identifiers. NIL for
-no prefixes. :prefix to prefix variables with something like packagename_identifier.")
-
-(defgeneric js-translate-symbol-contextually (symbol package env)
- (:documentation "Translates a symbol to a string in the given environment & package
-and for the given symbol."))
-
-(defmethod js-translate-symbol-contextually ((symbol symbol) (package ps::script-package) (env ps::compilation-environment))
- (cond ((member (ps::script-package-lisp-package package) (mapcar #'find-package '(:keyword :parenscript.global)))
- (symbol-to-js symbol))
- (*obfuscate-standard-identifiers* (obfuscated-symbol symbol))
- (t (if (and *enable-package-system* (eql *package-prefix-style* :prefix))
- (format nil "~A~A"
- (or (ps::script-package-prefix package) (concatenate 'string (ps::script-package-name package) "_"))
- (symbol-to-js symbol))
- (symbol-to-js symbol)))))
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ParenScript namespace system
+
+(in-package :parenscript)
+
+(defun ensure-ps-symbol (symbol)
+ (if (eq (symbol-package symbol) #.(find-package :parenscript))
+ symbol
+ (intern (symbol-name symbol) #.(find-package :parenscript))))
+
+;;; Symbol obfuscation
+(defvar *obfuscation-table* (make-hash-table))
+
+(defun obfuscate-package (package-designator)
+ (setf (gethash (find-package package-designator) *obfuscation-table*) (make-hash-table)))
+
+(defun unobfuscate-package (package-designator)
+ (remhash (find-package package-designator) *obfuscation-table*))
+
+(defun maybe-obfuscate-symbol (symbol)
+ (let ((obfuscated-symbol-table (gethash (symbol-package symbol) *obfuscation-table*)))
+ (if obfuscated-symbol-table
+ (or (gethash symbol obfuscated-symbol-table)
+ (setf (gethash symbol obfuscated-symbol-table) (ps-gensym "G")))
+ symbol)))
+
+;;; Interface for printing identifiers
+
+(defvar *package-prefix-table* (make-hash-table))
+
+(defmacro ps-package-prefix (package)
+ "Place for storing a string to be prefixed to any symbols in the
+designated package when translating ParenScript code."
+ `(gethash (find-package ,package) *package-prefix-table*))
+
+(defun js-translate-symbol (symbol)
+ (let ((possibly-obfuscated-symbol (maybe-obfuscate-symbol symbol)))
+ (if (ps-package-prefix (symbol-package symbol))
+ (format nil "~A~A" (ps-package-prefix (symbol-package symbol)) (symbol-to-js-string possibly-obfuscated-symbol))
+ (symbol-to-js-string possibly-obfuscated-symbol))))
HCoop / clinton / parenscript.git / blobdiff