Skip to content

Commit

Permalink
Merge pull request #9 from s-expressionists/compiler-environment-redo
Browse files Browse the repository at this point in the history
Rearrange the API again to fix compilation environments
  • Loading branch information
robert-strandh authored Oct 22, 2023
2 parents 277d514 + 25d17e7 commit 22cbc5e
Show file tree
Hide file tree
Showing 13 changed files with 663 additions and 454 deletions.
295 changes: 78 additions & 217 deletions Code/Basic/basic.lisp
Original file line number Diff line number Diff line change
@@ -1,265 +1,129 @@
(cl:in-package #:clostrum-basic)

;;; Function and variable entries.
(defclass operator-entry ()
((name
:initarg :name
:reader name)
(status
:initform nil
:accessor status
:type (member :function :macro :special-operator nil))
;; The CAR of the cell contains the function determined by the
;; entry. The CDR of the cell contains a function that, when
;; called, signals an error. When the function determined by the
;; entry is undefined, the CAR of the cell is the same as the CDR
;; of the cell.
(cell
:reader cell
:type cons)
(compiler-macro-function
:initform nil
:accessor compiler-macro-function
:type (or function null))
(setf-expander
:initform nil
:accessor setf-expander
:type (or function null)))
(:default-initargs :name (error "The initarg :NAME is required.")))

;;; Make sure NAME names a function entry in ENVIRONMENT.
;;; KEYWORD-ARGUMENTS are keyword/value pairs that will be passed
;;; either to MAKE-INSTANCE in order create a new entry if no entry
;;; exists, or will be passed to REINITIALIZE-INSTANCE to modify the
;;; existing entry if one does exist. The existing entry or the entry
;;; being created is returned.
(defun ensure-operator-entry (name environment &rest keyword-arguments)
(let ((entry (operator-entry name environment)))
(if (null entry)
(setf (operator-entry name environment)
(apply #'make-instance 'operator-entry
:name name keyword-arguments))
(apply #'reinitialize-instance entry keyword-arguments))))

(defmethod initialize-instance :after ((instance operator-entry) &key name)
;; We indicate that a function name is FUNBOUND by storing a
;; function in the CAR of the cell that, when called, signals an
;; UNDEFINED-FUNCTION error. This way, there is no need for an
;; explicit test to verify that the name is FBOUND before calling
;; the function. We store the same, as in EQ, function in the CDR
;; of the cell. That way, testing whether the function is unbound
;; is an EQ comparison between the CAR and the CDR of the cell, and
;; FMAKUNBOUND is implemented by copying the CDR of the cell to the
;; CAR.
(let ((unbound-function
(lambda (&rest args)
(declare (ignore args))
(error 'undefined-function :name name))))
(setf (slot-value instance 'cell)
(cons unbound-function unbound-function))))

(defun function-bound-p (operator-entry)
(let ((cell (cell operator-entry)))
(not (eq (car cell) (cdr cell)))))

(defconstant +unbound+ 'unbound)

(defclass variable-entry ()
((name
:initarg :name
:reader name)
(status
:initform nil
:accessor status
:type (member :constant :special :symbol-macro nil))
;; The CAR of the cell contains the value of the variable
;; determined by the entry. The CDR of the cell contains a value
;; that indicates that the variable is unbound. When the variable
;; is unbound, the CAR and the CDR contain the same value. Since
;; CL:MAKUNBOUND (which should really be called something else like
;; MAKE-TO-HAVE-NO-VALUE) must take into account dynamic bindings
;; of the variable, we do not supply code for MAKUNBOUND here. It
;; must be implemented by the client.
(cell
:reader cell
:initform (cons +unbound+ +unbound+)
:type cons)
(symbol-macro-expander
:accessor symbol-macro-expander
:type (or function null))
(plist
:initform nil
:accessor plist
:type list))
(:default-initargs :name (error "The initarg :NAME is required.")))

;;; Make sure NAME names a variable entry in ENVIRONMENT.
;;; KEYWORD-ARGUMENTS are keyword/value pairs that will be passed
;;; either to MAKE-INSTANCE in order create a new entry if no entry
;;; exists, or will be passed to REINITIALIZE-INSTANCE to modify the
;;; existing entry if one does exist. The existing entry or the entry
;;; being created is returned.
(defun ensure-variable-entry (name environment &rest keyword-arguments)
(let ((entry (variable-entry name environment)))
(if (null entry)
(setf (variable-entry name environment)
(apply #'make-instance 'variable-entry
:name name keyword-arguments))
(apply #'reinitialize-instance entry keyword-arguments))))

(defun variable-bound-p (variable-entry)
(let ((cell (cell variable-entry)))
(not (eq (car cell) +unbound+))))

(defclass type-entry ()
((%name :initarg :name :reader name)
(%cell :initform (cons nil nil) :reader cell :type cons)
(%type-expander :initform nil :accessor type-expander
:type (or function null))))

;;; Make sure NAME names a type entry in ENVIRONMENT.
;;; KEYWORD-ARGUMENTS are keyword/value pairs that will be passed either
;;; to MAKE-INSTANCE in order to create a new entry if none exits,
;;; or to REINITIALIZE-INSTANCE to modify an existing entry.
;;; The new or exiting entry is returned.
(defun ensure-type-entry (name environment &rest keyword-arguments)
(let ((entry (type-entry name environment)))
(if (null entry)
(setf entry (apply #'make-instance 'type-entry :name name
keyword-arguments)
(type-entry name environment) entry)
(apply #'reinitialize-instance entry keyword-arguments))
entry))

;;; Implementation of the Clostrum methods.

(declaim (inline cell-value (setf cell-value) cell-boundp cell-makunbound))
(defun cell-value (cell) (car cell))
(defun (setf cell-value) (new cell) (setf (car cell) new))
(defun cell-boundp (cell) (not (eq (car cell) (cdr cell))))
(defun cell-makunbound (cell) (setf (car cell) (cdr cell)) (values))

(defmethod sys:operator-cell-value (client cell)
(declare (ignore client))
(cell-value cell))
(defmethod (setf sys:operator-cell-value) (new client cell)
(defmethod sys:parent (client (env basic-environment))
(declare (ignore client))
(setf (cell-value cell) new))
(defmethod sys:operator-cell-boundp (client cell)
(declare (ignore client))
(cell-boundp cell))
(defmethod sys:operator-cell-makunbound (client cell)
(declare (ignore client))
(cell-makunbound cell))
(parent env))

(defmethod sys:operator-status (client (env run-time-environment) name)
(defmethod sys:operator-status (client (env basic-environment) name)
(declare (ignore client))
(let ((entry (operator-entry name env)))
(if (null entry)
nil
(status entry))))
(defmethod (setf sys:operator-status)
(new client (env run-time-environment) name)
(declare (ignore client))
(new client (env basic-environment) name)
(let ((entry (if (null new)
(operator-entry name env)
(ensure-operator-entry name env))))
(ensure-operator-entry client name env))))
(unless (null entry)
(setf (status entry) new)))
new)

(defmethod sys:operator-cell (client (environment run-time-environment) name)
(declare (ignore client))
(cell (ensure-operator-entry name environment)))

(defmethod sys:compiler-macro-function (client (env run-time-environment) name)
(defmethod sys:compiler-macro-function (client (env basic-environment) name)
(declare (ignore client))
(let ((entry (operator-entry name env)))
(if (null entry)
nil
(compiler-macro-function entry))))
(defmethod (setf sys:compiler-macro-function)
(new-value client (environment run-time-environment) name)
(declare (ignore client))
(new-value client (environment basic-environment) name)
(let ((entry (if (null new-value)
(operator-entry name environment)
(ensure-operator-entry name environment))))
(ensure-operator-entry client name environment))))
(unless (null entry)
(setf (compiler-macro-function entry) new-value)))
new-value)

(defmethod sys:setf-expander (client (env run-time-environment) name)
(defmethod sys:setf-expander (client (env basic-environment) name)
(declare (ignore client))
(let ((entry (operator-entry name env)))
(if (null entry)
nil
(setf-expander entry))))
(defmethod (setf sys:setf-expander)
(new-value client (environment run-time-environment) name)
(declare (ignore client))
(new-value client (environment basic-environment) name)
(let ((entry (if (null new-value)
(operator-entry name environment)
(ensure-operator-entry name environment))))
(ensure-operator-entry client name environment))))
(unless (null entry)
(setf (setf-expander entry) new-value)))
new-value)


;;; Variables.
(defmethod sys:variable-cell-value (client cell)
(defmethod sys:operator-inline (client (env basic-environment) name)
(declare (ignore client))
(cell-value cell))
(defmethod (setf sys:variable-cell-value) (new client cell)
(declare (ignore client))
(setf (cell-value cell) new))
(defmethod sys:variable-cell-boundp (client cell)
(let ((entry (operator-entry name env)))
(if (null entry)
nil
(inline entry))))
(defmethod (setf sys:operator-inline) (new client (env basic-environment) name)
(let ((entry (ensure-operator-entry client name env)))
(setf (inline-known-p entry) t (inline entry) new)))

(defmethod sys:operator-inline-known-p (client (env basic-environment) name)
(declare (ignore client))
(cell-boundp cell))
(defmethod sys:variable-cell-makunbound (client cell)
(let ((entry (operator-entry name env)))
(if (null entry)
nil
(inline-known-p entry))))

(defmethod sys:operator-inline-data (client (env basic-environment) name)
(declare (ignore client))
(cell-makunbound cell))
(let ((entry (operator-entry name env)))
(if (null entry)
nil
(inline-data entry))))
(defmethod (setf sys:operator-inline) (new client (env basic-environment) name)
(setf (inline-data (ensure-operator-entry client name env)) new))

(defmethod sys:variable-cell
(client (environment run-time-environment) symbol)
(cell (ensure-variable-entry symbol environment)))
(defmethod sys:operator-ftype (client (env basic-environment) name)
(let ((entry (operator-entry name env)))
(if (null entry)
(top-type client)
(ftype entry))))
(defmethod (setf sys:operator-ftype)
(new client (env basic-environment) name)
(setf (ftype (ensure-operator-entry client name env)) new))


;;; Variables.

(defmethod sys:variable-status
(client (environment run-time-environment) symbol)
(client (environment basic-environment) symbol)
(let ((entry (variable-entry symbol environment)))
(if (null entry)
nil
(status entry))))
(defmethod (setf sys:variable-status)
(new client (environment run-time-environment) symbol)
(new client (environment basic-environment) symbol)
(let ((entry (if (null new)
(variable-entry symbol environment)
(ensure-variable-entry symbol environment))))
(ensure-variable-entry client symbol environment))))
(unless (null entry)
(setf (status entry) new))
new))

(defmethod sys:variable-macro-expander
(client (environment run-time-environment) symbol)
(client (environment basic-environment) symbol)
(let ((entry (variable-entry symbol environment)))
(if (null entry)
nil
(symbol-macro-expander entry))))
(defmethod (setf sys:variable-macro-expander)
(new client (environment run-time-environment) symbol)
(new client (environment basic-environment) symbol)
;; NEW is always a function, as undefining a symbol macro is instead done by
;; changing its STATUS. So we don't need the (or ... (variable-entry ...))
(setf (symbol-macro-expander (ensure-variable-entry symbol environment)) new))
(setf (symbol-macro-expander (ensure-variable-entry client symbol environment)) new))

(defmethod sys:symbol-plist (client (environment run-time-environment) symbol)
(declare (ignore client))
(defmethod sys:variable-type (client (environment basic-environment) symbol)
(let ((entry (variable-entry symbol environment)))
(if (null entry)
nil
(plist entry))))
(defmethod (setf sys:symbol-plist)
(new client (environment run-time-environment) symbol)
(declare (ignore client))
(setf (plist (ensure-variable-entry symbol environment)) new))
(if entry
(vtype entry)
(top-type client))))
(defmethod (setf sys:variable-type)
(new client (environment basic-environment) symbol)
(setf (vtype (ensure-variable-entry client symbol environment)) new))


;;; Types and classes.
Expand All @@ -277,52 +141,49 @@
(declare (ignore client))
(cell-makunbound cell))

(defmethod sys:type-cell (client (environment run-time-environment) symbol)
(defmethod sys:type-cell (client (environment basic-environment) symbol)
(declare (ignore client))
(let ((entry (type-entry symbol environment)))
(if entry
(cell entry)
nil)))

(defmethod sys:ensure-type-cell (client (environment basic-environment) symbol)
(cell (ensure-type-entry symbol environment)))

(defmethod sys:type-expander (client (environment run-time-environment) symbol)
(defmethod sys:type-expander (client (environment basic-environment) symbol)
(let ((entry (type-entry symbol environment)))
(if (null entry)
nil
(type-expander entry))))
(defmethod (setf sys:type-expander)
(new client (environment run-time-environment) symbol)
(new client (environment basic-environment) symbol)
(let ((entry (if (null new)
(type-entry symbol environment)
(ensure-type-entry symbol environment))))
(unless (null entry)
(setf (type-expander entry) new)))
new)

;;; Packages.

(defmethod sys:find-package
(client (environment run-time-environment) name)
(values (gethash name (packages environment))))

(defmethod (setf sys:find-package)
(new-package client (environment run-time-environment) name)
(if (null new-package)
(remhash name (packages environment))
(setf (gethash name (packages environment)) new-package)))

(defmethod sys:map-all-packages
(client (environment run-time-environment) function)
(maphash (lambda (name package)
(declare (ignore name))
(funcall function package))
(packages environment)))


;;; Declarations.

(defmethod sys:proclamation
(client (environment run-time-environment) name)
(client (environment basic-environment) name)
(values (gethash name (declarations environment))))

(defmethod (setf sys:proclamation)
(new-value client (environment run-time-environment) name)
(new-value client (environment basic-environment) name)
(cond ((null new-value)
(remhash name (declarations environment)))
(t
(setf (gethash name (declarations environment)) new-value))))


;;; Optimize.
(defmethod sys:optimize (client (environment basic-environment))
(declare (ignore client))
(optimize environment))
(defmethod (setf sys:optimize) (new client (environment basic-environment))
(declare (ignore client))
(setf (optimize environment) new))
Loading

0 comments on commit 22cbc5e

Please sign in to comment.