diff --git a/coalton.asd b/coalton.asd index 9b744792..769ab896 100644 --- a/coalton.asd +++ b/coalton.asd @@ -8,9 +8,9 @@ :depends-on (#:alexandria #:global-vars #:trivia - #:serapeum #:fset #:float-features + #:split-sequence #:uiop) :in-order-to ((asdf:test-op (asdf:test-op #:coalton/tests))) :around-compile (lambda (compile) diff --git a/src/algorithm/immutable-listmap.lisp b/src/algorithm/immutable-listmap.lisp index 028e0712..ea555d0d 100644 --- a/src/algorithm/immutable-listmap.lisp +++ b/src/algorithm/immutable-listmap.lisp @@ -5,8 +5,8 @@ ;; Wrapper around fset:map ;; -(serapeum:defstruct-read-only immutable-listmap - (data (fset:empty-map (fset:empty-seq)) :type fset:map)) +(defstruct immutable-listmap + (data (fset:empty-map (fset:empty-seq)) :type fset:map) :read-only t) (defun immutable-listmap-lookup (m key &key no-error) "Lookup key in M" diff --git a/src/algorithm/immutable-map.lisp b/src/algorithm/immutable-map.lisp index 2255b105..4e3327ae 100644 --- a/src/algorithm/immutable-map.lisp +++ b/src/algorithm/immutable-map.lisp @@ -6,8 +6,14 @@ ;; Wrapper around fset:map ;; -(serapeum:defstruct-read-only immutable-map - (data (fset:empty-map) :type fset:map)) +(defstruct immutable-map + (data (fset:empty-map) :type fset:map :read-only t)) + +(defmethod make-load-form ((self immutable-map) &optional env) + (make-load-form-saving-slots + self + :slot-names '(data) + :environment env)) (defun immutable-map-lookup (m key) "Lookup KEY in M" diff --git a/src/ast/node.lisp b/src/ast/node.lisp index 7d7cb9b5..38ec9e5d 100644 --- a/src/ast/node.lisp +++ b/src/ast/node.lisp @@ -1,9 +1,7 @@ (in-package #:coalton-impl/ast) -(serapeum:defstruct-read-only - (node - (:constructor nil)) - (unparsed :type t)) +(defstruct (node (:constructor nil)) + (unparsed (required 'unparsed) :type t :read-only t)) (defun node-list-p (x) (and (alexandria:proper-list-p x) @@ -45,102 +43,102 @@ #+sbcl (declaim (sb-ext:freeze-type literal-value)) -(serapeum:defstruct-read-only +(defstruct (node-literal (:include node) (:constructor node-literal (unparsed value))) "A literal value. These include things like integers and strings." - (value :type literal-value)) + (value (required 'value) :type literal-value :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-literal)) -(serapeum:defstruct-read-only +(defstruct (node-variable (:include node) (:constructor node-variable (unparsed name))) - (name :type symbol)) + (name (required 'name) :type symbol :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-variable)) -(serapeum:defstruct-read-only +(defstruct (node-application (:include node) (:constructor node-application (unparsed rator rands))) - (rator :type node) - (rands :type node-list)) + (rator (required 'rator) :type node :read-only t) + (rands (required 'rands) :type node-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-application)) -(serapeum:defstruct-read-only +(defstruct (node-abstraction (:include node) (:constructor node-abstraction (unparsed vars subexpr name-map))) - (vars :type symbol-list) - (subexpr :type node) - (name-map :type list)) + (vars (required 'vars) :type t :read-only t) + (subexpr (required 'subexpr) :type node :read-only t) + (name-map (required 'name-map) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-abstraction)) -(serapeum:defstruct-read-only +(defstruct (node-let (:include node) (:constructor node-let (unparsed bindings subexpr name-map))) - (bindings :type binding-list) - (subexpr :type node) - (name-map :type list)) + (bindings (required 'bindings) :type binding-list :read-only t) + (subexpr (required 'subexpr) :type node :read-only t) + (name-map (required 'name-map) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-let)) -(serapeum:defstruct-read-only +(defstruct (node-lisp (:include node) (:constructor node-lisp (unparsed type variables form))) - (type :type t) - (variables :type list) - (form :type t)) + (type (required 'type) :type t :read-only t) + (variables (required 'variables) :type t :read-only t) + (form (required 'form) :type t :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-lisp)) -(serapeum:defstruct-read-only match-branch - (unparsed :type t) - (pattern :type pattern) - (subexpr :type node) - (name-map :type list)) +(defstruct match-branch + (unparsed (required 'unparsed) :type t :read-only t) + (pattern (required 'pattern) :type pattern :read-only t) + (subexpr (required 'subexpr) :type node :read-only t) + (name-map (required 'name-map) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type match-branch)) -(serapeum:defstruct-read-only +(defstruct (node-match (:include node) (:constructor node-match (unparsed expr branches))) - (expr :type node) - (branches :type list)) + (expr (required 'expr) :type node :read-only t) + (branches (required 'branches) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-match)) -(serapeum:defstruct-read-only +(defstruct (node-seq (:include node) (:constructor node-seq (unparsed subnodes))) - (subnodes :type node-list)) + (subnodes (required 'subnodes) :type node-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-seq)) -(serapeum:defstruct-read-only +(defstruct (node-the (:include node) (:constructor node-the (unparsed type subnode))) - (type :type t) - (subnode :type node)) + (type (required 'type) :type t :read-only t) + (subnode (required 'subnode) :type node :read-only t)) #+sbcl (declaim (sb-ext:freeze-type node-the)) diff --git a/src/ast/pattern.lisp b/src/ast/pattern.lisp index ca787309..136c5d61 100644 --- a/src/ast/pattern.lisp +++ b/src/ast/pattern.lisp @@ -4,7 +4,7 @@ ;;; Patterns ;;; -(serapeum:defstruct-read-only (pattern (:constructor nil))) +(defstruct (pattern (:constructor nil))) (defun pattern-list-p (x) (and (alexandria:proper-list-p x) @@ -16,16 +16,16 @@ #+sbcl (declaim (sb-ext:freeze-type pattern-list)) -(serapeum:defstruct-read-only +(defstruct (pattern-var (:include pattern) (:constructor pattern-var (id))) - (id :type symbol)) + (id (required 'id) :type symbol :read-only t)) #+sbcl (declaim (sb-ext:freeze-type pattern-var)) -(serapeum:defstruct-read-only +(defstruct (pattern-wildcard (:include pattern) (:constructor pattern-wildcard))) @@ -33,21 +33,21 @@ #+sbcl (declaim (sb-ext:freeze-type pattern-wildcard)) -(serapeum:defstruct-read-only +(defstruct (pattern-literal (:include pattern) (:constructor pattern-literal (value))) - (value :type node-literal)) + (value (required 'value) :type node-literal :read-only t)) #+sbcl (declaim (sb-ext:freeze-type pattern-literal)) -(serapeum:defstruct-read-only +(defstruct (pattern-constructor (:include pattern) - (:constructor pattern-constructor (name patterns))) - (name :type symbol) - (patterns :type pattern-list)) + (:coNstructor Pattern-constructor (name patterns))) + (name (required 'name) :type symbol :read-only t) + (patterns (required 'type) :type pattern-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type pattern-constructor)) diff --git a/src/codegen/function-entry.lisp b/src/codegen/function-entry.lisp index f19d64e6..e8adaaf1 100644 --- a/src/codegen/function-entry.lisp +++ b/src/codegen/function-entry.lisp @@ -2,10 +2,10 @@ ;; We need to evaluate this early so the macro below can inline calls (eval-when (:load-toplevel) - (serapeum:defstruct-read-only function-entry - (arity :type fixnum) - (function :type function) - (curried :type function)) + (defstruct function-entry + (arity (required 'arity) :type fixnum :read-only t) + (function (required 'function) :type function :read-only t) + (curried (required 'curried) :type function :read-only t)) #+sbcl (declaim (sb-ext:freeze-type function-entry))) diff --git a/src/codegen/optimizer.lisp b/src/codegen/optimizer.lisp index bc405a10..bfc7feee 100644 --- a/src/codegen/optimizer.lisp +++ b/src/codegen/optimizer.lisp @@ -1,9 +1,10 @@ (in-package #:coalton-impl/codegen) -(serapeum:defstruct-read-only (optimizer - (:constructor optimizer (env toplevel-functions))) - (env :type environment) - (toplevel-functions :type list)) +(defstruct + (optimizer + (:constructor optimizer (env toplevel-functions))) + (env (required 'env) :type environment :read-only t) + (toplevel-functions (required 'toplevel-functions) :type list :read-only t)) (defun make-optimizer (env) (declare (type environment env) diff --git a/src/codegen/utilities.lisp b/src/codegen/utilities.lisp index 38795016..1e12c731 100644 --- a/src/codegen/utilities.lisp +++ b/src/codegen/utilities.lisp @@ -1,8 +1,8 @@ (in-package #:coalton-impl/codegen) -(serapeum:defstruct-read-only struct-or-class-field - (name :type symbol) - (type :type t)) +(defstruct struct-or-class-field + (name (required 'name) :type symbol :read-only t) + (type (required 'type) :type t :read-only t)) #+sbcl (declaim (sb-ext:freeze-type struct-or-class-field)) diff --git a/src/library/vector.lisp b/src/library/vector.lisp index 02c779ac..5f815f94 100644 --- a/src/library/vector.lisp +++ b/src/library/vector.lisp @@ -46,8 +46,8 @@ "Return a new vector containing the same elements as V" (match v ((Vector v) - (lisp (Vector :a) (v) - (Vector (alexandria:copy-array v)))))) + (lisp (Vector :a) (v) + (Vector (alexandria:copy-array v)))))) (declare vector-push (:a -> (Vector :a) -> Integer)) (define (vector-push item v) @@ -272,10 +272,25 @@ (define-instance (Into (Vector :a) (List :a)) (define (into v) (let ((inner - (fn (v index) - (if (>= index (vector-length v)) - Nil - (Cons (vector-index-unsafe index v) (inner v (+ 1 index))))))) - (inner v 0)))) + (fn (v index) + (if (>= index (vector-length v)) + Nil + (Cons (vector-index-unsafe index v) (inner v (+ 1 index))))))) + (inner v 0)))) - (define-instance (Iso (Vector :a) (List :a)))) + (define-instance (Iso (Vector :a) (List :a))) + + (coalton-toplevel + (declare vector-to-list ((Vector :a) -> (List :a))) + (define (vector-to-list v) + (match v + ((Vector v) + (lisp (List :a) (v) + (cl:coerce v 'cl:list))))))) + + +(coalton-toplevel + (declare v (Vector Integer)) + (define v (into (make-list 1 2 3 4 5))) + + (define v2 (map (+ 2) v))) diff --git a/src/package.lisp b/src/package.lisp index e47ddfae..f8c08a88 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -104,8 +104,6 @@ (:use #:cl #:coalton-impl/algorithm #:coalton-impl/ast) - (:import-from #:serapeum - #:true) (:export #:ty ; STRUCT #:ty-scheme ; STRUCT diff --git a/src/typechecker/context-reduction.lisp b/src/typechecker/context-reduction.lisp index 3c573710..500c36eb 100644 --- a/src/typechecker/context-reduction.lisp +++ b/src/typechecker/context-reduction.lisp @@ -4,6 +4,11 @@ ;; Context reduction ;; +(defun true (x) + (if x + t + nil)) + (defun by-super (env pred) "Recursively get all super classes of predicate diff --git a/src/typechecker/environment.lisp b/src/typechecker/environment.lisp index f610fcbe..694b0b15 100644 --- a/src/typechecker/environment.lisp +++ b/src/typechecker/environment.lisp @@ -4,7 +4,7 @@ ;;; Value type environments ;;; -(serapeum:defstruct-read-only (value-environment (:include immutable-map))) +(defstruct (value-environment (:include immutable-map))) #+sbcl (declaim (sb-ext:freeze-type value-environment)) @@ -21,14 +21,14 @@ ;;; Type environments ;;; -(serapeum:defstruct-read-only (type-entry (:constructor type-entry)) - (name :type symbol) - (runtime-type :type t) - (type :type ty) +(defstruct (type-entry (:constructor type-entry)) + (name (required 'name) :type symbol :read-only t) + (runtime-type (required 'runtime-type) :type t :read-only t) + (type (required 'type) :type ty :read-only t) ;; If this is true then the type is compiled to a more effecient ;; enum representation at runtime - (enum-repr :type boolean) + (enum-repr (required 'enum-repr) :type boolean :read-only t) ;; If this is true then the type does not exist at runtime ;; See https://wiki.haskell.org/Newtype @@ -43,7 +43,13 @@ ;; A type that is a newtype has another Coalton type as it's ;; runtime-type instead of a lisp type. This is to avoid issues with ;; recursive newtypes. - (newtype :type boolean)) + (newtype (required 'newtype) :type boolean :read-only t)) + +(defmethod make-load-form ((self type-entry) &optional env) + (make-load-form-saving-slots + self + :slot-names '(name runtime-type type enum-repr newtype) + :environment env)) (defmethod coalton-impl/typechecker::kind-of ((entry type-entry)) (coalton-impl/typechecker::kind-of (type-entry-type entry))) @@ -51,7 +57,7 @@ #+sbcl (declaim (sb-ext:freeze-type type-entry)) -(serapeum:defstruct-read-only (type-environment (:include immutable-map))) +(defstruct (type-environment (:include immutable-map))) #+sbcl (declaim (sb-ext:freeze-type type-environment)) @@ -178,17 +184,23 @@ ;;; Constructor environment ;;; -(serapeum:defstruct-read-only constructor-entry - (name :type symbol) - (arity :type alexandria:non-negative-fixnum) - (constructs :type symbol) - (scheme :type ty-scheme) - (arguments :type scheme-list) - (classname :type symbol) +(defstruct constructor-entry + (name (required 'name) :type symbol :read-only t) + (arity (required 'arity) :type alexandria:non-negative-fixnum :read-only t) + (constructs (required 'constructs) :type symbol :read-only t) + (scheme (required 'scheme) :type ty-scheme :read-only t) + (arguments (required 'arguments) :type scheme-list :read-only t) + (classname (required 'classname) :type symbol :read-only t) ;; If this constructor constructs a compressed-repr type then ;; compressed-repr is the runtime value of this nullary constructor - (compressed-repr :type t)) + (compressed-repr (required 'compressed-repr) :type t :read-only t)) + +(defmethod make-load-form ((self constructor-entry) &optional env) + (make-load-form-saving-slots + self + :slot-names '(name arity constructs scheme arguments classname compressed-repr) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type constructor-entry)) @@ -204,13 +216,13 @@ (declaim (sb-ext:freeze-type constructor-entry-list)) -(serapeum:defstruct-read-only (constructor-environment (:include immutable-map))) +(defstruct (constructor-environment (:include immutable-map))) (defun make-default-constructor-environment () "Create a TYPE-ENVIRONMENT containing early constructors" (let* ((tvar (make-variable)) - (list-scheme (%make-ty-scheme (list tvar) (qualify nil (%make-tapp tList tvar)))) - (var-scheme (%make-ty-scheme (list tvar) (qualify nil tvar)))) + (list-scheme (quantify (list tvar) (qualify nil (%make-tapp tList tvar)))) + (var-scheme (quantify (list tvar) (qualify nil tvar)))) (make-constructor-environment :data (fset:map ;; Early Constructors @@ -261,19 +273,25 @@ ;;; Class environment ;;; -(serapeum:defstruct-read-only +(defstruct (ty-class (:constructor ty-class (name predicate superclasses unqualified-methods codegen-sym superclass-dict docstring location))) - (name :type symbol) - (predicate :type ty-predicate) - (superclasses :type ty-predicate-list) + (name (required 'name) :type symbol :read-only t) + (predicate (required 'predicate) :type ty-predicate :read-only t) + (superclasses (requried 'superclasses) :type ty-predicate-list :read-only t) ;; Methods of the class containing the same tyvars in PREDICATE for ;; use in pretty printing - (unqualified-methods :type scheme-binding-list) - (codegen-sym :type symbol) - (superclass-dict :type list) - (docstring :type (or null string)) - (location :type t)) + (unqualified-methods (required 'unqualified-methods) :type scheme-binding-list :read-only t) + (codegen-sym (required 'codegen-sym) :type symbol :read-only t) + (superclass-dict (required 'superclass-dict) :type list :read-only t) + (docstring (required 'docstring) :type (or null string) :read-only t) + (location (required 'location) :type t :read-only t)) + +(defmethod make-load-form ((self ty-class) &optional env) + (make-load-form-saving-slots + self + :slot-names '(name predicate superclasses unqualified-methods codegen-sym superclass-dict docstring location) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type ty-class)) @@ -306,7 +324,7 @@ (ty-class-docstring class) (ty-class-location class))) -(serapeum:defstruct-read-only (class-environment (:include immutable-map))) +(defstruct (class-environment (:include immutable-map))) #+sbcl (declaim (sb-ext:freeze-type class-environment)) @@ -315,12 +333,18 @@ ;;; Instance environment ;;; -(serapeum:defstruct-read-only +(defstruct (ty-class-instance (:constructor ty-class-instance (constraints predicate codegen-sym))) - (constraints :type ty-predicate-list) - (predicate :type ty-predicate) - (codegen-sym :type symbol)) + (constraints (required 'constraints) :type ty-predicate-list :read-only t) + (predicate (required 'predicate) :type ty-predicate :read-only t) + (codegen-sym (required 'codegen-sym) :type symbol :read-only t)) + +(defmethod make-load-form ((self ty-class-instance) &optional env) + (make-load-form-saving-slots + self + :slot-names '(constraints predicate codegen-sym) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type ty-class-instance)) @@ -343,7 +367,7 @@ (apply-substitution subst-list (ty-class-instance-predicate instance)) (ty-class-instance-codegen-sym instance))) -(serapeum:defstruct-read-only (instance-environment (:include immutable-listmap))) +(defstruct (instance-environment (:include immutable-listmap))) #+sbcl (declaim (sb-ext:freeze-type instance-environment)) @@ -352,9 +376,15 @@ ;;; Function environment ;;; -(serapeum:defstruct-read-only function-env-entry - (name :type symbol) - (arity :type fixnum)) +(defstruct function-env-entry + (name (required 'name) :type symbol :read-only t) + (arity (required 'arity) :type fixnum :read-only t)) + +(defmethod make-load-form ((self function-env-entry) &optional env) + (make-load-form-saving-slots + self + :slot-names '(name arity) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type function-env-entry)) @@ -369,7 +399,7 @@ #+sbcl (declaim (sb-ext:freeze-type function-env-entry-list)) -(serapeum:defstruct-read-only (function-environment (:include immutable-map))) +(defstruct (function-environment (:include immutable-map))) #+sbcl (declaim (sb-ext:freeze-type function-environment)) @@ -378,16 +408,22 @@ ;;; Name environment ;;; -(serapeum:defstruct-read-only name-entry - (name :type symbol) - (type :type (member :value :method :constructor)) - (docstring :type (or null string)) - (location :type t)) +(defstruct name-entry + (name (required 'name) :type symbol :read-only t) + (type (required 'type) :type (member :value :method :constructor) :read-only t) + (docstring (required 'docstring) :type (or null string) :read-only t) + (location (required 'location) :type t) :read-only t) + +(defmethod make-load-form ((self name-entry) &optional env) + (make-load-form-saving-slots + self + :slot-names '(name type docstring location) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type name-entry)) -(serapeum:defstruct-read-only (name-environment (:include immutable-map))) +(defstruct (name-environment (:include immutable-map))) #+sbcl (declaim (sb-ext:freeze-type name-environment)) @@ -396,7 +432,7 @@ ;;; Environment ;;; -(serapeum:defstruct-read-only +(defstruct (environment (:constructor make-environment (value-environment @@ -406,13 +442,19 @@ instance-environment function-environment name-environment))) - (value-environment :type value-environment) - (type-environment :type type-environment) - (constructor-environment :type constructor-environment) - (class-environment :type class-environment) - (instance-environment :type instance-environment) - (function-environment :type function-environment) - (name-environment :type name-environment)) + (value-environment (required 'value-environment) :type value-environment :read-only t) + (type-environment (required 'type-environment) :type type-environment :read-only t) + (constructor-environment (requried 'constructor-environment) :type constructor-environment :read-only t) + (class-environment (required 'class-environment) :type class-environment :read-only t) + (instance-environment (required 'instance-environment) :type instance-environment :read-only t) + (function-environment (required 'function-environment) :type function-environment :read-only t) + (name-environment (required 'name-environment) :type name-environment) :read-only t) + +(defmethod make-load-form ((self environment) &optional env) + (make-load-form-saving-slots + self + :slot-names '(value-environment type-environment constructor-environment class-environment instance-environment function-environment name-environment) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type environment)) diff --git a/src/typechecker/kinds.lisp b/src/typechecker/kinds.lisp index 6522852f..9c04c720 100644 --- a/src/typechecker/kinds.lisp +++ b/src/typechecker/kinds.lisp @@ -4,21 +4,33 @@ ;;; Kinds ;;; -(serapeum:defstruct-read-only (kind (:constructor nil))) +(defstruct (kind (:constructor nil))) -(serapeum:defstruct-read-only (kstar (:include kind))) +(defstruct (kstar (:include kind))) + +(defmethod make-load-form ((self kstar) &optional env) + (make-load-form-saving-slots + self + :slot-names nil + :environment env)) #+sbcl (declaim (sb-ext:freeze-type kstar)) (alexandria:define-constant kstar (make-instance 'kstar) :test #'equalp) -(serapeum:defstruct-read-only +(defstruct (kfun (:include kind) (:constructor kfun (from to))) - (from :type kind) - (to :type kind)) + (from (required 'from) :type kind :read-only t) + (to (required 'to) :type kind :read-only t)) + +(defmethod make-load-form ((self kfun) &optional env) + (make-load-form-saving-slots + self + :slot-names '(from to) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type kfun)) diff --git a/src/typechecker/parse-instance-definition.lisp b/src/typechecker/parse-instance-definition.lisp index ee2718f9..54d84c1f 100644 --- a/src/typechecker/parse-instance-definition.lisp +++ b/src/typechecker/parse-instance-definition.lisp @@ -4,12 +4,12 @@ ;;; Parsing instance defintions ;;; -(serapeum:defstruct-read-only instance-definition - (class-name :type symbol) - (predicate :type ty-predicate) - (context :type ty-predicate-list) - (methods :type typed-binding-list) - (codegen-sym :type symbol)) +(defstruct instance-definition + (class-name (required 'class-name) :type symbol :read-only t) + (predicate (required 'predicate) :type ty-predicate :read-only t) + (context (required 'context) :type ty-predicate-list :read-only t) + (methods (required 'methods) :type typed-binding-list :read-only t) + (codegen-sym (required 'codegen-sym) :type symbol :read-only t)) (defun instance-definition-list-p (x) (and (alexandria:proper-list-p x) diff --git a/src/typechecker/parse-type-definition.lisp b/src/typechecker/parse-type-definition.lisp index be6b5b3d..a7d7e527 100644 --- a/src/typechecker/parse-type-definition.lisp +++ b/src/typechecker/parse-type-definition.lisp @@ -5,16 +5,16 @@ ;;; -(serapeum:defstruct-read-only type-definition - (name :type symbol) - (type :type ty) - (runtime-type :type t) +(defstruct type-definition + (name (required 'name) :type symbol :read-only t) + (type (required 'type) :type ty :read-only t) + (runtime-type (required 'runtime-type) :type t :read-only t) ;; See the fields with the same name on type-entry - (enum-repr :type boolean) - (newtype :type boolean) + (enum-repr (required 'enum-repr) :type boolean :read-only t) + (newtype (required 'newtype) :type boolean :read-only t) - (constructors :type constructor-entry-list)) + (constructors (required 'constructors) :type constructor-entry-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type type-definition)) diff --git a/src/typechecker/predicate.lisp b/src/typechecker/predicate.lisp index 951b6588..a09ebf98 100644 --- a/src/typechecker/predicate.lisp +++ b/src/typechecker/predicate.lisp @@ -4,12 +4,18 @@ ;;; Type predicates ;;; -(serapeum:defstruct-read-only +(defstruct (ty-predicate (:constructor ty-predicate (class types))) "A type predicate indicating that TYPE is of the CLASS" - (class :type symbol) - (types :type ty-list)) + (class (required 'class) :type symbol :read-only t) + (types (required 'types) :type ty-list :read-only t)) + +(defmethod make-load-form ((self ty-predicate) &optional env) + (make-load-form-saving-slots + self + :slot-names '(class types) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type ty-predicate)) @@ -29,11 +35,16 @@ ;;; Qualified types ;;; -(serapeum:defstruct-read-only +(defstruct (qualified-ty (:constructor qualified-ty (predicates type))) - (predicates :type ty-predicate-list) - (type :type ty)) + (predicates (required 'predicates) :type ty-predicate-list :read-only t) + (type (required 'type) :type ty :read-only t)) + +(defmethod make-load-form ((self qualified-ty) &optional env) + (make-load-form-saving-slots + self + :slot-names '(predicates type))) #+sbcl (declaim (sb-ext:freeze-type qualified-ty)) diff --git a/src/typechecker/scheme.lisp b/src/typechecker/scheme.lisp index 11b370d5..322b5ea5 100644 --- a/src/typechecker/scheme.lisp +++ b/src/typechecker/scheme.lisp @@ -4,9 +4,15 @@ ;;; Type schemes ;;; -(serapeum:defstruct-read-only (ty-scheme (:constructor %make-ty-scheme (kinds type))) - (kinds :type list) - (type :type qualified-ty)) +(defstruct (ty-scheme (:constructor %make-ty-scheme (kinds type))) + (kinds (required 'kinds) :type list :read-only t) + (type (required 'type) :type qualified-ty :read-only t)) + +(defmethod make-load-form ((self ty-scheme) &optional env) + (make-load-form-saving-slots + self + :slot-names '(kinds type) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type ty-scheme)) diff --git a/src/typechecker/typed-node.lisp b/src/typechecker/typed-node.lisp index c3059965..8ab4d666 100644 --- a/src/typechecker/typed-node.lisp +++ b/src/typechecker/typed-node.lisp @@ -4,9 +4,9 @@ ;;; Typed AST nodes ;;; -(serapeum:defstruct-read-only (typed-node (:constructor nil)) - (type :type ty-scheme) - (unparsed :type t)) +(defstruct (typed-node (:constructor nil)) + (type (required 'type) :type ty-scheme :read-only t) + (unparsed (required 'unparsed) :type t :read-only t)) (defun typed-node-list-p (x) (and (alexandria:proper-list-p x) @@ -28,39 +28,39 @@ #+sbcl (declaim (sb-ext:freeze-type typed-binding-list)) -(serapeum:defstruct-read-only +(defstruct (typed-node-literal (:include typed-node) (:constructor typed-node-literal (type unparsed value))) - (value :type literal-value)) + (value (required 'value) :type literal-value :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-literal)) -(serapeum:defstruct-read-only +(defstruct (typed-node-variable (:include typed-node) (:constructor typed-node-variable (type unparsed name))) ;; The name of the variable - (name :type symbol)) + (name (required 'name) :type symbol :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-variable)) -(serapeum:defstruct-read-only +(defstruct (typed-node-application (:include typed-node) (:constructor typed-node-application (type unparsed rator rands))) ;; The function - (rator :type typed-node) + (rator (required 'rator) :type typed-node :read-only t) ;; The arguments - (rands :type typed-node-list)) + (rands (required 'rands) :type typed-node-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-application)) -(serapeum:defstruct-read-only +(defstruct (typed-node-direct-application (:include typed-node) (:constructor typed-node-direct-application (type unparsed rator-type rator rands))) @@ -68,78 +68,78 @@ This allows emitting a direct call instead of funcalling a function-entry." ;; The type of the function - (rator-type :type ty-scheme) + (rator-type (required 'rator-type) :type ty-scheme :read-only t) ;; The name of the function - (rator :type symbol) + (rator (required 'rator) :type symbol :read-only t) ;; The arguments - (rands :type typed-node-list)) + (rands (required 'rands) :type typed-node-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-direct-application)) -(serapeum:defstruct-read-only +(defstruct (typed-node-abstraction (:include typed-node) (:constructor typed-node-abstraction (type unparsed vars subexpr name-map))) ;; The functions arguments and their types - (vars :type scheme-binding-list) + (vars (required 'vars) :type scheme-binding-list :read-only t) ;; The body of the function - (subexpr :type typed-node) + (subexpr (required 'subexpr) :type typed-node :read-only t) ;; An alist mapping of the current paramater names ;; to their origional names - (name-map :type list)) + (name-map (required 'name-map) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-abstraction)) -(serapeum:defstruct-read-only +(defstruct (typed-node-let (:include typed-node) (:constructor typed-node-let (type unparsed bindings subexpr sorted-bindings dynamic-extent-bindings name-map))) ;; Bindings declared in the let - (bindings :type typed-binding-list) + (bindings (required 'bindings) :type typed-binding-list :read-only t) ;; The body of the let expression - (subexpr :type typed-node) + (subexpr (required 'subexpr) :type typed-node :read-only t) ;; The bindings' SCCS - (sorted-bindings :type list) + (sorted-bindings (required 'sorted-bindings) :type list :read-only t) ;; Bindings which can be declared dynamic-extent durring codegen - (dynamic-extent-bindings :type symbol-list) + (dynamic-extent-bindings (required 'dynamic-extent-bindings) :type symbol-list :read-only t) ;; An alist mapping the current binding names ;; to their origional names - (name-map :type list)) + (name-map (required 'name-map) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-let)) -(serapeum:defstruct-read-only +(defstruct (typed-node-lisp (:include typed-node) (:constructor typed-node-lisp (type unparsed variables form))) ;; Local variables used in the lisp block - (variables :type list) + (variables (required 'variables) :type list :read-only t) ;; The lisp block - (form :type t)) + (form (required 'form) :type t :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-lisp)) -(serapeum:defstruct-read-only +(defstruct (typed-match-branch (:constructor typed-match-branch (unparsed pattern subexpr bindings name-map))) - (unparsed :type t) - (pattern :type pattern) - (subexpr :type typed-node) - (bindings :type scheme-binding-list) - (name-map :type list)) + (unparsed (required 'unparsed) :type t :read-only t) + (pattern (required 'pattern) :type pattern :read-only t) + (subexpr (required 'subexpr) :type typed-node :read-only t) + (bindings (required 'bindings) :type scheme-binding-list :read-only t) + (name-map (required 'name-map) :type list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-match-branch)) @@ -154,21 +154,21 @@ #+sbcl (declaim (sb-ext:freeze-type typed-match-branch-list)) -(serapeum:defstruct-read-only +(defstruct (typed-node-match (:include typed-node) (:constructor typed-node-match (type unparsed expr branches))) - (expr :type typed-node) - (branches :type typed-match-branch-list)) + (expr (required 'expr) :type typed-node :read-only t) + (branches (required 'branches) :type typed-match-branch-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-match)) -(serapeum:defstruct-read-only +(defstruct (typed-node-seq (:include typed-node) (:constructor typed-node-seq (type unparsed subnodes))) - (subnodes :type typed-node-list)) + (subnodes (required 'subnodes) :type typed-node-list :read-only t)) #+sbcl (declaim (sb-ext:freeze-type typed-node-seq)) diff --git a/src/typechecker/types.lisp b/src/typechecker/types.lisp index c4ba8d1d..b52eac6f 100644 --- a/src/typechecker/types.lisp +++ b/src/typechecker/types.lisp @@ -4,7 +4,7 @@ ;;; Types ;;; -(serapeum:defstruct-read-only (ty (:constructor nil))) +(defstruct (ty (:constructor nil))) (defun ty-list-p (x) (and (alexandria:proper-list-p x) @@ -26,9 +26,13 @@ #+sbcl (declaim (sb-ext:freeze-type ty-binding-list)) -(serapeum:defstruct-read-only (tyvar (:constructor %make-tyvar)) - (id :type fixnum) - (kind :type kind)) +(defstruct (tyvar (:constructor %make-tyvar)) + (id (required 'id) :type fixnum :read-only t) + (kind (required 'kind) :type kind :read-only t)) +(defmethod make-load-form ((self tyvar) &optional env) (make-load-form-saving-slots + self + :slot-names '(id kind) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type tyvar)) @@ -43,9 +47,16 @@ #+sbcl (declaim (sb-ext:freeze-type tyvar-list)) -(serapeum:defstruct-read-only (tvar (:include ty) - (:constructor %make-tvar (tyvar))) - (tyvar (required 'tyvar) :type tyvar)) +(defstruct + (tvar (:include ty) + (:constructor %make-tvar (tyvar))) + (tyvar (required 'tyvar) :type tyvar :read-only t)) + +(defmethod make-load-form ((self tvar) &optional env) + (make-load-form-saving-slots + self + :slot-names '(tyvar) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type tvar)) @@ -60,31 +71,58 @@ #+sbcl (declaim (sb-ext:freeze-type tvar-list)) -(serapeum:defstruct-read-only (tycon (:constructor %make-tycon)) - (name :type symbol) - (kind :type kind)) +(defstruct (tycon (:constructor %make-tycon)) + (name (required 'name) :type symbol :read-only t) + (kind (required 'kind) :type kind :read-only t)) + +(defmethod make-load-form ((self tycon) &optional env) + (make-load-form-saving-slots + self + :slot-names '(name kind) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type tycon)) -(serapeum:defstruct-read-only (tcon (:include ty) - (:constructor %make-tcon (tycon))) - (tycon :type tycon)) +(defstruct + (tcon (:include ty) + (:constructor %make-tcon (tycon))) + (tycon (required 'tycon) :type tycon :read-only t)) + +(defmethod make-load-form ((self tcon) &optional env) + (make-load-form-saving-slots + self + :slot-names '(tycon) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type tcon)) -(serapeum:defstruct-read-only (tapp (:include ty) - (:constructor %make-tapp (from to))) - (from :type ty) - (to :type ty)) +(defstruct + (tapp (:include ty) + (:constructor %make-tapp (from to))) + (from (required 'from) :type ty :read-only t) + (to (required 'to) :type ty :read-only t)) + +(defmethod make-load-form ((self tapp) &optional env) + (make-load-form-saving-slots + self + :slot-names '(from to) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type tapp)) -(serapeum:defstruct-read-only (tgen (:include ty) - (:constructor %make-tgen (id))) - (id :type fixnum)) +(defstruct + (tgen (:include ty) + (:constructor %make-tgen (id))) + (id (required 'id) :type fixnum :read-only t)) + +(defmethod make-load-form ((self tgen) &optional env) + (make-load-form-saving-slots + self + :slot-names '(id) + :environment env)) #+sbcl (declaim (sb-ext:freeze-type tgen)) diff --git a/src/utilities.lisp b/src/utilities.lisp index a9a21cd9..8d21da34 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -2,6 +2,10 @@ (in-package #:coalton-impl) +(defun required (name) + (declare (type symbol name)) + (error "Property ~S is required" name)) + (define-condition coalton-bug (error) ((reason :initarg :reason :reader coalton-bug-reason)