diff --git a/src/global-environment.lisp b/src/global-environment.lisp index 775a8a9..13c712b 100644 --- a/src/global-environment.lisp +++ b/src/global-environment.lisp @@ -12,9 +12,12 @@ source-form node) +(make-load-form-for-struct entry) + + (define-global-var **global-value-definitions** (make-hash-table :test 'eql) - "Database of Coalton global value definitions.") + "Database of Coalton global value definitions. This is a map from vars (symbols) to ENTRYs.") (defun var-knownp (var) "Have we seen VAR?" @@ -39,7 +42,7 @@ (check-type new-value entry) (check-type var symbol) (when (var-knownp var) - (warn "Overwriting info entry for ~S" var)) + (style-warn "Overwriting info entry for ~S" var)) (setf (gethash var **global-value-definitions**) new-value)) (defun make-internal-name (s) @@ -65,7 +68,7 @@ (check-type new-value ty) (let ((info (var-info var))) (when (entry-declared-type info) - (warn "Overwriting declared type of ~S" var)) + (style-warn "Overwriting declared type of ~S" var)) (alexandria:when-let ((derived (var-derived-type var))) (unless (more-or-equally-specific-type-p derived new-value) (error "Cannot declare ~S as ~S because that is ~ @@ -83,7 +86,7 @@ (check-type new-value ty) (let ((info (var-info var))) (when (entry-derived-type info) - (warn "Overwriting derived type of ~S" var)) + (style-warn "Overwriting derived type of ~S" var)) (alexandria:when-let ((declared (var-declared-type var))) (unless (more-or-equally-specific-type-p new-value declared) (error "The derived type of ~S, which is ~S, is incompatible ~ diff --git a/src/toplevel-define-type.lisp b/src/toplevel-define-type.lisp index b016280..9e56c55 100644 --- a/src/toplevel-define-type.lisp +++ b/src/toplevel-define-type.lisp @@ -101,6 +101,14 @@ where ;; TODO: Structs? Vectors? Classes? This should be thought ;; about. Let's start with classes. `(progn + ;; Make sure database side effects are maintained. + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (find-tycon ',tycon-name) ,tycon) + ,@(loop :for (_ name ty) :in ctors + :collect `(unless (var-knownp ',name) + (forward-declare-variable ',name)) + :collect `(setf (var-declared-type ',name) ,ty))) + ;; Define types. Create the superclass. ;; ;; TODO: handle special case of 1 ctor. diff --git a/src/types.lisp b/src/types.lisp index 6bbe4d0..34fd28c 100644 --- a/src/types.lisp +++ b/src/types.lisp @@ -17,6 +17,8 @@ ;; nice to make it read-only though. (constructors nil :type alexandria:proper-list)) +(make-load-form-for-struct tycon) + ;;; TODO: figure out type aliases. (define-global-var **type-definitions** (make-hash-table :test 'eql) "Database of Coalton type definitions. These are mappings from symbols to type constructors.") @@ -38,7 +40,7 @@ (check-type tycon-name symbol) (check-type new-value tycon) (when (tycon-knownp tycon-name) - (warn "Clobbering tycon ~S" tycon-name)) + (style-warn "Clobbering tycon ~S" tycon-name)) (setf (gethash tycon-name **type-definitions**) new-value)) (defun find-tycon-for-ctor (name) @@ -57,12 +59,16 @@ (instance nil :type (or null ty) :read-only nil) (name nil :type (or null symbol) :read-only nil)) +(make-load-form-for-struct tyvar) + (defstruct (tyapp (:include ty) (:constructor tyapp (constructor &rest types))) "A type application. (Note that this could be the application of a 0-arity constructor.)" (constructor nil :type tycon :read-only t) (types nil :type type-list :read-only t)) +(make-load-form-for-struct tyapp) + (defun tyapp-name (tyapp) (tycon-name (tyapp-constructor tyapp))) @@ -74,6 +80,8 @@ (from nil :type type-list :read-only t) (to nil :type ty :read-only t)) +(make-load-form-for-struct tyfun) + (defun tyfun-arity (tyfun) (length (tyfun-from tyfun))) diff --git a/src/utilities.lisp b/src/utilities.lisp index 56805a1..20541ff 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -28,3 +28,27 @@ :reason-control reason-control :reason-args reason-args)) +(defun make-collector () + (let* ((tail (cons nil nil)) + (items tail)) + (lambda (&optional (item nil itemp)) + (cond + ((not itemp) (cdr items)) + (t + (rplacd tail (cons item nil)) + (setf tail (cdr tail)) + item))))) + +(defmacro record-side-effects! ((collector) &body forms) + `(progn + ,@forms + (funcall ,collector '(progn ,@forms)))) + +(defmacro make-load-form-for-struct (struct-name) + `(defmethod make-load-form ((s ,struct-name) &optional env) + (make-load-form-saving-slots s :environment env))) + +(defun style-warn (format-control &rest format-args) + (format t "~&; ") + (apply #'format t format-control format-args) + (fresh-line))