(:file "utils" :depends-on ("package"))
(:file "js-source-model" :depends-on ("package" "utils"))
(:file "ps-source-model" :depends-on ("js-source-model"))
- (:file "parser" :depends-on ("js-source-model" "ps-source-model"))
+ (:file "namespace" :depends-on ("js-source-model" "ps-source-model"))
+ (:file "parser" :depends-on ("js-source-model" "ps-source-model" "namespace"))
(:file "builtin-packages" :depends-on ("parser"))
(:file "deprecated-interface" :depends-on ("parser"))
(:file "parse-lambda-list" :depends-on ("package"))
nil
))
+(defgeneric install-standard-script-packages (comp-env)
+ (:documentation "Creates standard script packages and installs them in the current compilation
+environment."))
+
(defmethod install-standard-script-packages ((comp-env compilation-environment))
(list
(create-script-package
finally (write-char *js-quote-char* escaped)))))
;;; variables
-(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."))
-
-(defparameter *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)))))
-
-(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
- (case *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)))
- (t
- (symbol-to-js (value symbol)))))))
-
(defgeneric js-translate-symbol (var)
(:documentation "Given a JS-VARIABLE returns an output
JavaScript version of it as a string."))
(js-translate-symbol (value var)))
(defmethod js-translate-symbol ((var-name symbol))
- (js-translate-symbol-contextually var-name (ps::symbol-script-package var-name) ps::*compilation-environment*))
+ (ps::js-translate-symbol-contextually var-name (ps::symbol-script-package var-name) ps::*compilation-environment*))
(defmethod js-to-strings ((v js-variable) start-form)
(declare (ignore start-form))
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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)))))
+
(in-package :parenscript)
;;;; The mechanisms for defining macros & parsing Parenscript.
-
-(eval-when (:compile-toplevel :load-toplevel)
- (defun macro-name-hash-function ()
- #'eql))
-
-(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."))
-
(defgeneric compiler-in-situation-p (comp-env situation)
(:documentation "Returns true when the compiler is considered 'in' the situation
given by SITUATION, which is one of :compile-toplevel :execute.")
(comp-env-compiling-toplevel-p comp-env)
))
-(defvar *compilation-environment* nil
- "The active compilation environment."
-;; Right now all code assumes that *compilation-environment* is accurately bound to the
-;; current compilation environment--even some functions that take the compilation environment
-;; as arguments.
- )
-
-(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.")
-
-(defvar *warn-ps-package* nil
- "If true, warns when ParenScript attempts to compile symbols that
-don't have an associated ParenScript package.")
-
-;;; parenscript packages
-(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)))
-
-
-
-;; environmental considerations
-(defgeneric setup-compilation-environment (comp-env)
- (:documentation "Sets up a basic compilation environment prepared for a language user.
-This should do things like define packages and set the current package.
-
-Returns the compilation-environment."))
-
-(defgeneric install-standard-script-packages (comp-env)
- (:documentation "Creates standard script packages and installs them in the current compilation
-environment."))
-
-(defun make-basic-compilation-environment ()
- "Creates a compilation environment object from scratch. Fills it in with the default
-script packages (parenscript, global, and parenscript-user)."
- (let ((*compilation-environment* (make-instance 'compilation-environment)))
- (setup-compilation-environment *compilation-environment*)))
-
-(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
-
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *toplevel-special-forms* (make-hash-table :test #'equal)
"A hash-table containing functions that implement Parenscript special forms,
indexed by name (as symbols)")
(defun undefine-script-special-form (name)
"Undefines the special form with the given name (name is a symbol)."
- (remhash (symbol-name name) *toplevel-special-forms*)))
+ (remhash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*)))
(defmacro define-script-special-form (name lambda-list &rest body)
"Define a special form NAME. Arguments are destructured according to
LAMBDA-LIST. The resulting Parenscript language types are appended to the
ongoing javascript compilation."
(let ((arglist (gensym "ps-arglist-")))
- `(setf (gethash ,(symbol-name name) *toplevel-special-forms*)
+ `(setf (gethash (lisp-symbol-to-ps-identifier ',name :special-form) *toplevel-special-forms*)
(lambda (&rest ,arglist)
(destructuring-bind ,lambda-list
,arglist
(defun get-script-special-form (name)
"Returns the special form function corresponding to the given name."
- (gethash (symbol-name name) *toplevel-special-forms*))
+ (gethash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*))
;;; sexp form predicates
(defun script-special-form-p (form)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-macro-env-dictionary ()
"Creates a standard macro dictionary."
- (make-hash-table :test (macro-name-hash-function)))
+ (make-hash-table :test #'equal))
(defvar *script-macro-toplevel* (make-macro-env-dictionary)
"Toplevel macro environment dictionary. Key is the symbol of the
macro, value is (symbol-macro-p . expansion-function).")
- (defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil)
+ (defvar *script-macro-env* (list *script-macro-toplevel*)
"Current macro environment.")
(defvar *script-setf-expanders* (make-macro-env-dictionary)
arguments of the access functions as a first value and the form to be
stored as the second value.")
- (defun find-macro-spec (name env-dict)
- (gethash name env-dict))
- (defsetf find-macro-spec (name env-dict)
- (spec)
- `(setf (gethash ,name ,env-dict) ,spec)))
-
-
-(defmacro get-macro-spec (name env-dict)
- "Retrieves the macro spec of the given name with the given environment dictionary.
+ (defun get-macro-spec (name env-dict)
+ "Retrieves the macro spec of the given name with the given environment dictionary.
SPEC is of the form (symbol-macro-p . expansion-function)."
- `(find-macro-spec ,name ,env-dict))
+ (gethash (lisp-symbol-to-ps-identifier name :macro) env-dict))
+ (defsetf get-macro-spec (name env-dict)
+ (spec)
+ `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec)))
(defun lookup-macro-spec (name &optional (environment *script-macro-env*))
"Looks up the macro spec associated with NAME in the given environment. A
(concatenate 'string
prefix (princ-to-string (incf *gen-script-name-counter*))))
-(defun gen-script-name (&key (prefix ""))
+(defun gen-script-name (&key (prefix "_ps_"))
"Generate a new javascript identifier."
(intern (gen-script-name-string :prefix prefix)
(find-package :parenscript.ps-gensyms)))
,@effective-body)))
(ps:defscriptmacro defsetf-long (access-fn lambda-list (store-var) form)
- (setf (find-macro-spec access-fn *script-setf-expanders*)
+ (setf (get-macro-spec access-fn *script-setf-expanders*)
(compile nil
(let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
`(lambda (access-fn-args store-form)
(ps:defscriptmacro defsetf-short (access-fn update-fn &optional docstring)
(declare (ignore docstring))
- (setf (find-macro-spec access-fn *script-setf-expanders*)
+ (setf (get-macro-spec access-fn *script-setf-expanders*)
(lambda (access-fn-args store-form)
`(,update-fn ,@access-fn-args ,store-form)))
nil)
(defpsmacro setf (&rest args)
(flet ((process-setf-clause (place value-form)
- (if (and (listp place) (find-macro-spec (car place) *script-setf-expanders*))
- (funcall (find-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
+ (if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*))
+ (funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
(let ((exp-place (expand-script-form place)))
- (if (and (listp exp-place) (find-macro-spec (car exp-place) *script-setf-expanders*))
- (funcall (find-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
+ (if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*))
+ (funcall (get-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
`(parenscript.javascript::setf1% ,exp-place ,value-form))))))
(assert (evenp (length args)) ()
"~s does not have an even number of arguments." (cons 'setf args))
(defscriptclass script-quote (ps-js::expression)
())
+;;; Compilation environment stuff
+
+(defvar *compilation-environment* nil
+ "The active compilation environment."
+;; Right now all code assumes that *compilation-environment* is accurately bound to the
+;; current compilation environment--even some functions that take the compilation environment
+;; as arguments.
+ )
+
+;; environmental considerations
+(defgeneric setup-compilation-environment (comp-env)
+ (:documentation "Sets up a basic compilation environment prepared for a language user.
+This should do things like define packages and set the current package.
+
+Returns the compilation-environment."))
+
+(defun make-basic-compilation-environment ()
+ "Creates a compilation environment object from scratch. Fills it in with the default
+script packages (parenscript, global, and parenscript-user)."
+ (let ((*compilation-environment* (make-instance 'compilation-environment)))
+ (setup-compilation-environment *compilation-environment*)))
\ No newline at end of file
HCoop / clinton / parenscript.git / commitdiff