From 3cb857fea676d86622dba622775d4e1de33e6464 Mon Sep 17 00:00:00 2001 From: Jesse Bouwman Date: Mon, 8 Jul 2024 11:27:36 -0700 Subject: [PATCH] Add 'lisp-toplevel' form to coalton syntax lisp-toplevel may appear at any point in a coalton-toplevel or coalton file context. During code generation, lisp forms are merged with coalton definitions according to the rule: 1. coalton forms are emitted in scc order 2. every time a coalton form is emitted, all lisp forms lexically preceding that form are emitted first Convert math/num.lisp from interleaved lisp and coalton-toplevel forms to a single coalton-toplevel form containing multiple lisp-toplevel forms. Lisp-toplevel is, initially, restricted to library source code. --- coalton.asd | 7 +- library/math/num.lisp | 657 +++++++++--------- src/codegen/program.lisp | 136 +++- src/entry.lisp | 77 +- src/faux-macros.lisp | 3 + src/package.lisp | 1 + src/parser/cursor.lisp | 21 +- src/parser/renamer.lisp | 1 + src/parser/toplevel.lisp | 137 +++- src/typechecker/translation-unit.lisp | 13 +- .../lisp-toplevel-forbid.txt | 20 + tests/parser-test-files/lisp-toplevel.txt | 64 ++ tests/parser-tests.lisp | 3 + 13 files changed, 707 insertions(+), 433 deletions(-) create mode 100644 tests/parser-test-files/lisp-toplevel-forbid.txt create mode 100644 tests/parser-test-files/lisp-toplevel.txt diff --git a/coalton.asd b/coalton.asd index ef450021e..4c9bb7816 100644 --- a/coalton.asd +++ b/coalton.asd @@ -27,7 +27,12 @@ :version (:read-file-form "VERSION.txt") :around-compile (lambda (compile) (let (#+sbcl (sb-ext:*derive-function-types* t) - #+sbcl (sb-ext:*block-compile-default* :specified)) + #+sbcl (sb-ext:*block-compile-default* :specified) + ;; The lisp-toplevel form is currently + ;; restricted to standard library + ;; implementation by checking for the + ;; presence of this feature. + (*features* (cons ':coalton-lisp-toplevel *features*))) (funcall compile))) :defsystem-depends-on (#:coalton-asdf) :depends-on (#:coalton-compiler diff --git a/library/math/num.lisp b/library/math/num.lisp index f2006ba6a..6947e8758 100644 --- a/library/math/num.lisp +++ b/library/math/num.lisp @@ -24,30 +24,33 @@ #+coalton-release (cl:declaim #.coalton-impl/settings:*coalton-optimize-library*) +(coalton-toplevel + ;;; ;;; Constants ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defconstant +fixnum-bits+ - #+sbcl sb-vm:n-fixnum-bits - #-sbcl (cl:1+ (cl:floor (cl:log cl:most-positive-fixnum 2)))) - (cl:defconstant +unsigned-fixnum-bits+ - (cl:1- +fixnum-bits+))) + (lisp-toplevel () + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defconstant +fixnum-bits+ + #+sbcl sb-vm:n-fixnum-bits + #-sbcl (cl:1+ (cl:floor (cl:log cl:most-positive-fixnum 2)))) + (cl:defconstant +unsigned-fixnum-bits+ + (cl:1- +fixnum-bits+))) ;;; ;;; Eq Instances ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-eq (type) - `(define-instance (Eq ,type) - (define (== a b) - (lisp Boolean (a b) - ;; Use cl:= so that (== 0.0 -0.0) => True - (cl:= a b)))))) + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-eq (type) + `(define-instance (Eq ,type) + (define (== a b) + (lisp Boolean (a b) + ;; Use cl:= so that (== 0.0 -0.0) => True + (cl:= a b))))))) -(coalton-toplevel (define-eq Integer) (define-eq IFix) (define-eq UFix) @@ -60,59 +63,60 @@ (define-eq I64) (define-eq U64) (define-eq Single-Float) - (define-eq Double-Float)) + (define-eq Double-Float) ;;; ;;; Ord Instances ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-ord (type) - (cl:let ((>-spec (alexandria:format-symbol cl:*package* "~A->" type)) - (>=-spec (alexandria:format-symbol cl:*package* "~A->=" type)) - (<-spec (alexandria:format-symbol cl:*package* "~A-< type" type)) - (<=-spec (alexandria:format-symbol cl:*package* "~A-<=" type))) - - ;; Generates the instance and specializations to use more direct - ;; comparison functions when possible. - - `(progn - (define-instance (Ord ,type) - (define (<=> a b) - (lisp Ord (a b) - (cl:cond - ((cl:< a b) - LT) - ((cl:> a b) - GT) - (cl:t - EQ))))) - - (specialize > ,>-spec (,type -> ,type -> Boolean)) - (declare ,>-spec (,type -> ,type -> Boolean)) - (define (,>-spec a b) - (lisp Boolean (a b) - (to-boolean (cl:> a b)))) - - (specialize >= ,>=-spec (,type -> ,type -> Boolean)) - (declare ,>=-spec (,type -> ,type -> Boolean)) - (define (,>=-spec a b) - (lisp Boolean (a b) - (to-boolean (cl:>= a b)))) - - (specialize < ,<-spec (,type -> ,type -> Boolean)) - (declare ,<-spec (,type -> ,type -> Boolean)) - (define (,<-spec a b) - (lisp Boolean (a b) - (to-boolean (cl:< a b)))) - - (specialize <= ,<=-spec (,type -> ,type -> Boolean)) - (declare ,<=-spec (,type -> ,type -> Boolean)) - (define (,<=-spec a b) - (lisp Boolean (a b) - (to-boolean (cl:<= a b)))))))) + (lisp-toplevel () + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-ord (type) + (cl:let ((>-spec (alexandria:format-symbol cl:*package* "~A->" type)) + (>=-spec (alexandria:format-symbol cl:*package* "~A->=" type)) + (<-spec (alexandria:format-symbol cl:*package* "~A-< type" type)) + (<=-spec (alexandria:format-symbol cl:*package* "~A-<=" type))) + + ;; Generates the instance and specializations to use more direct + ;; comparison functions when possible. + + `(progn + (define-instance (Ord ,type) + (define (<=> a b) + (lisp Ord (a b) + (cl:cond + ((cl:< a b) + LT) + ((cl:> a b) + GT) + (cl:t + EQ))))) + + (specialize > ,>-spec (,type -> ,type -> Boolean)) + (declare ,>-spec (,type -> ,type -> Boolean)) + (define (,>-spec a b) + (lisp Boolean (a b) + (to-boolean (cl:> a b)))) + + (specialize >= ,>=-spec (,type -> ,type -> Boolean)) + (declare ,>=-spec (,type -> ,type -> Boolean)) + (define (,>=-spec a b) + (lisp Boolean (a b) + (to-boolean (cl:>= a b)))) + + (specialize < ,<-spec (,type -> ,type -> Boolean)) + (declare ,<-spec (,type -> ,type -> Boolean)) + (define (,<-spec a b) + (lisp Boolean (a b) + (to-boolean (cl:< a b)))) + + (specialize <= ,<=-spec (,type -> ,type -> Boolean)) + (declare ,<=-spec (,type -> ,type -> Boolean)) + (define (,<=-spec a b) + (lisp Boolean (a b) + (to-boolean (cl:<= a b))))))))) -(coalton-toplevel (define-ord Integer) (define-ord IFix) (define-ord UFix) @@ -125,83 +129,85 @@ (define-ord I64) (define-ord U64) (define-ord Single-Float) - (define-ord Double-Float)) + (define-ord Double-Float) ;;; ;;; Overflow checks for signed values ;;; -(cl:declaim (cl:inline %unsigned->signed)) -(cl:defun %unsigned->signed (bits x) - ;; This is the two's complement conversion of X (interpreted as BITS - ;; bits) to a signed integer (as a Lisp object). - (cl:- - (cl:ldb (cl:byte (cl:1- bits) 0) x) - (cl:dpb 0 (cl:byte (cl:1- bits) 0) x))) - -(cl:defmacro %define-overflow-handler (name bits) - `(cl:progn - (cl:declaim (cl:inline ,name)) - (cl:defun ,name (value) - (cl:typecase value - ((cl:signed-byte ,bits) value) - (cl:otherwise - (cl:cerror "Continue, wrapping around." - ,(cl:format cl:nil "Signed value overflowed ~D bits." bits)) - (%unsigned->signed ,bits (cl:mod value ,(cl:expt 2 bits)))))))) - - -(%define-overflow-handler %handle-8bit-overflow 8) -(%define-overflow-handler %handle-16bit-overflow 16) -(%define-overflow-handler %handle-32bit-overflow 32) -(%define-overflow-handler %handle-64bit-overflow 64) -(%define-overflow-handler %handle-fixnum-overflow #.+fixnum-bits+) + (lisp-toplevel () + + (cl:declaim (cl:inline %unsigned->signed)) + (cl:defun %unsigned->signed (bits x) + ;; This is the two's complement conversion of X (interpreted as BITS + ;; bits) to a signed integer (as a Lisp object). + (cl:- + (cl:ldb (cl:byte (cl:1- bits) 0) x) + (cl:dpb 0 (cl:byte (cl:1- bits) 0) x))) + + (cl:defmacro %define-overflow-handler (name bits) + `(cl:progn + (cl:declaim (cl:inline ,name)) + (cl:defun ,name (value) + (cl:typecase value + ((cl:signed-byte ,bits) value) + (cl:otherwise + (cl:cerror "Continue, wrapping around." + ,(cl:format cl:nil "Signed value overflowed ~D bits." bits)) + (%unsigned->signed ,bits (cl:mod value ,(cl:expt 2 bits)))))))) + + + (%define-overflow-handler %handle-8bit-overflow 8) + (%define-overflow-handler %handle-16bit-overflow 16) + (%define-overflow-handler %handle-32bit-overflow 32) + (%define-overflow-handler %handle-64bit-overflow 64) + (%define-overflow-handler %handle-fixnum-overflow #.+fixnum-bits+) ;;; ;;; Num instances for integers ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-num-checked (type overflow-handler) - "Define a `Num' instance for TYPE which signals on overflow." - `(define-instance (Num ,type) - (define (+ a b) - (lisp ,type (a b) - (,overflow-handler (cl:+ a b)))) - - (define (- a b) - (lisp ,type (a b) - (,overflow-handler (cl:- a b)))) - - (define (* a b) - (lisp ,type (a b) - (,overflow-handler (cl:* a b)))) - - (define (fromInt x) - (lisp ,type (x) - (,overflow-handler x)))))) - -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-num-wrapping (type bits) - "Define a `Num' instance for TYPE which wraps on overflow." - `(define-instance (Num ,type) - (define (+ a b) - (lisp ,type (a b) - (cl:values (cl:mod (cl:+ a b) ,(cl:expt 2 bits))))) - - (define (- a b) - (lisp ,type (a b) - (cl:values (cl:mod (cl:- a b) ,(cl:expt 2 bits))))) - - (define (* a b) - (lisp ,type (a b) - (cl:values (cl:mod (cl:* a b) ,(cl:expt 2 bits))))) - - (define (fromInt x) - (lisp ,type (x) - (cl:values (cl:mod x ,(cl:expt 2 bits)))))))) + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-num-checked (type overflow-handler) + "Define a `Num' instance for TYPE which signals on overflow." + `(define-instance (Num ,type) + (define (+ a b) + (lisp ,type (a b) + (,overflow-handler (cl:+ a b)))) + + (define (- a b) + (lisp ,type (a b) + (,overflow-handler (cl:- a b)))) + + (define (* a b) + (lisp ,type (a b) + (,overflow-handler (cl:* a b)))) + + (define (fromInt x) + (lisp ,type (x) + (,overflow-handler x)))))) + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-num-wrapping (type bits) + "Define a `Num' instance for TYPE which wraps on overflow." + `(define-instance (Num ,type) + (define (+ a b) + (lisp ,type (a b) + (cl:values (cl:mod (cl:+ a b) ,(cl:expt 2 bits))))) + + (define (- a b) + (lisp ,type (a b) + (cl:values (cl:mod (cl:- a b) ,(cl:expt 2 bits))))) + + (define (* a b) + (lisp ,type (a b) + (cl:values (cl:mod (cl:* a b) ,(cl:expt 2 bits))))) + + (define (fromInt x) + (lisp ,type (x) + (cl:values (cl:mod x ,(cl:expt 2 bits))))))))) + -(coalton-toplevel (define-num-checked Integer cl:identity) (define-num-checked I8 %handle-8bit-overflow) @@ -214,213 +220,217 @@ (define-num-wrapping U16 16) (define-num-wrapping U32 32) (define-num-wrapping U64 64) - (define-num-wrapping UFix #.+unsigned-fixnum-bits+)) + (define-num-wrapping UFix #.+unsigned-fixnum-bits+) ;;; ;;; Num instances for floats ;;; -(cl:defun %optional-coerce (z cl-type) - "Attempts to coerce Z to an Optional CL-TYPE, returns NONE if failed." - (cl:let ((x (cl:ignore-errors - (cl:coerce z cl-type)))) - (cl:if (cl:null x) - None - (Some x)))) - -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-num-float (type lisp-type) - "Define `Num' for TYPE" - - ;; - ;; CCL has a tendency to re-enable float traps. The explicit float - ;; trap masking keeps the test suite working during interactive - ;; development. - ;; - ;; Allegro appears to have some checks that make some arithmetic - ;; functions error on some inputs. The explicit checks in division - ;; keep the behavior consistent with IEEE 754. - ;; - - `(define-instance (Num ,type) - (define (+ a b) - (lisp ,type (a b) - (#+(not ccl) cl:progn - #+ccl ff:with-float-traps-masked #+ccl cl:t - (cl:+ a b)))) - - (define (- a b) - (lisp ,type (a b) - (#+(not ccl) cl:progn - #+ccl ff:with-float-traps-masked #+ccl cl:t - (cl:- a b)))) - - (define (* a b) - (lisp ,type (a b) - (#+(not ccl) cl:progn - #+ccl ff:with-float-traps-masked #+ccl cl:t - (cl:* a b)))) - - (define (fromInt x) - (match (lisp (Optional ,type) (x) - (%optional-coerce x ',lisp-type)) - ((Some x) x) - ((None) (if (< 0 x) - negative-infinity - infinity))))))) + (lisp-toplevel () + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defun %optional-coerce (z cl-type) + "Attempts to coerce Z to an Optional CL-TYPE, returns NONE if failed." + (cl:let ((x (cl:ignore-errors + (cl:coerce z cl-type)))) + (cl:if (cl:null x) + None + (Some x)))) + + (cl:defmacro define-num-float (type lisp-type) + "Define `Num' for TYPE" + + ;; + ;; CCL has a tendency to re-enable float traps. The explicit float + ;; trap masking keeps the test suite working during interactive + ;; development. + ;; + ;; Allegro appears to have some checks that make some arithmetic + ;; functions error on some inputs. The explicit checks in division + ;; keep the behavior consistent with IEEE 754. + ;; + + `(define-instance (Num ,type) + (define (+ a b) + (lisp ,type (a b) + (#+(not ccl) cl:progn + #+ccl ff:with-float-traps-masked #+ccl cl:t + (cl:+ a b)))) + + (define (- a b) + (lisp ,type (a b) + (#+(not ccl) cl:progn + #+ccl ff:with-float-traps-masked #+ccl cl:t + (cl:- a b)))) + + (define (* a b) + (lisp ,type (a b) + (#+(not ccl) cl:progn + #+ccl ff:with-float-traps-masked #+ccl cl:t + (cl:* a b)))) + + (define (fromInt x) + (match (lisp (Optional ,type) (x) + (%optional-coerce x ',lisp-type)) + ((Some x) x) + ((None) (if (< 0 x) + negative-infinity + infinity)))))))) -(coalton-toplevel (define-num-float Single-Float cl:single-float) - (define-num-float Double-Float cl:double-float)) + (define-num-float Double-Float cl:double-float) ;;; ;;; Float to `Fraction' conversions ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-float-fraction-conversion (type) - `(define-instance (TryInto ,type Fraction String) - (define (tryInto x) - (if (finite? x) - (Ok (lisp Fraction (x) (cl:rational x))) - (Err "Could not convert NaN or infinity into a Fraction")))))) + (lisp-toplevel () + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-float-fraction-conversion (type) + `(define-instance (TryInto ,type Fraction String) + (define (tryInto x) + (if (finite? x) + (Ok (lisp Fraction (x) (cl:rational x))) + (Err "Could not convert NaN or infinity into a Fraction"))))))) -(coalton-toplevel (define-float-fraction-conversion Single-Float) - (define-float-fraction-conversion Double-Float)) + (define-float-fraction-conversion Double-Float) ;;; ;;; `Dividable' and `Reciprocable' instances for floata ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-reciprocable-float (type) - `(define-instance (Reciprocable ,type) - (define (/ x y) - (cond - #+allegro - ((or (nan? x) - (nan? y)) - nan) - - #+allegro - ((and (== x 0) (== y 0)) - nan) - - #+allegro - ((and (positive? x) (== y 0)) - infinity) - - #+allegro - ((and (negative? x) (== y 0)) - negative-infinity) - - (True - (lisp ,type (x y) - (#+(not ccl) cl:progn - #+ccl ff:with-float-traps-masked #+ccl cl:t - (cl:/ x y)))))) - - (define (reciprocal x) - (cond - #+allegro - ((== x 0) - infinity) - - (True - (lisp ,type (x) - (#+(not ccl) cl:progn - #+ccl ff:with-float-traps-masked #+ccl cl:t - (cl:/ x))))))))) - -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-dividable-float (type lisp-type) - `(define-instance (Dividable Integer ,type) - (define (general/ x y) - (if (== y 0) - (/ (fromInt x) (fromInt y)) - (match (lisp (Optional ,type) (x y) - (%optional-coerce (cl:/ x y) ',lisp-type)) - ((Some x) x) - ((None) (if (and (> x 0) (> y 0)) - infinity - negative-infinity)))))))) + (lisp-toplevel () + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-reciprocable-float (type) + `(define-instance (Reciprocable ,type) + (define (/ x y) + (cond + #+allegro + ((or (nan? x) + (nan? y)) + nan) + + #+allegro + ((and (== x 0) (== y 0)) + nan) + + #+allegro + ((and (positive? x) (== y 0)) + infinity) + + #+allegro + ((and (negative? x) (== y 0)) + negative-infinity) + + (True + (lisp ,type (x y) + (#+(not ccl) cl:progn + #+ccl ff:with-float-traps-masked #+ccl cl:t + (cl:/ x y)))))) + + (define (reciprocal x) + (cond + #+allegro + ((== x 0) + infinity) + + (True + (lisp ,type (x) + (#+(not ccl) cl:progn + #+ccl ff:with-float-traps-masked #+ccl cl:t + (cl:/ x))))))))) + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-dividable-float (type lisp-type) + `(define-instance (Dividable Integer ,type) + (define (general/ x y) + (if (== y 0) + (/ (fromInt x) (fromInt y)) + (match (lisp (Optional ,type) (x y) + (%optional-coerce (cl:/ x y) ',lisp-type)) + ((Some x) x) + ((None) (if (and (> x 0) (> y 0)) + infinity + negative-infinity))))))))) -(coalton-toplevel (define-reciprocable-float Single-Float) (define-reciprocable-float Double-Float) (define-dividable-float Single-Float cl:single-float) - (define-dividable-float Double-Float cl:double-float)) + (define-dividable-float Double-Float cl:double-float) ;;; ;;; `Bits' instances ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-bits-checked (type handle-overflow) - `(define-instance (bits:Bits ,type) - (define (bits:and a b) - (lisp ,type (a b) - (cl:logand a b))) - - (define (bits:or a b) - (lisp ,type (a b) - (cl:logior a b))) - - (define (bits:xor a b) - (lisp ,type (a b) - (cl:logxor a b))) - - (define (bits:not x) - (lisp ,type (x) - (cl:lognot x))) - - (define (bits:shift amount bits) - (lisp ,type (amount bits) - (,handle-overflow (cl:ash bits amount))))))) - -(cl:declaim (cl:inline unsigned-lognot)) -(cl:defun unsigned-lognot (int n-bits) - (cl:declare (cl:type cl:unsigned-byte int) - (cl:type cl:unsigned-byte n-bits) - (cl:values cl:unsigned-byte)) - - (cl:- (cl:ash 1 n-bits) int 1)) - -(cl:declaim (cl:inline handle-unsigned-overflow)) -(cl:defun handle-unsigned-overflow (int n-bits) - (cl:declare (cl:type cl:unsigned-byte int) - (cl:type cl:unsigned-byte n-bits) - (cl:values cl:unsigned-byte)) - - (cl:logand (cl:1- (cl:ash 1 n-bits)) int)) - -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-bits-wrapping (type width) - `(define-instance (bits:Bits ,type) - (define (bits:and a b) - (lisp ,type (a b) - (cl:logand a b))) - - (define (bits:or a b) - (lisp ,type (a b) - (cl:logior a b))) - - (define (bits:xor a b) - (lisp ,type (a b) - (cl:logxor a b))) - - (define (bits:not x) - (lisp ,type (x) - (unsigned-lognot x ,width))) - - (define (bits:shift amount bits) - (lisp ,type (amount bits) - (cl:logand (cl:ash bits amount) - ,(cl:1- (cl:ash 1 width)))))))) + (lisp-toplevel () + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-bits-checked (type handle-overflow) + `(define-instance (bits:Bits ,type) + (define (bits:and a b) + (lisp ,type (a b) + (cl:logand a b))) + + (define (bits:or a b) + (lisp ,type (a b) + (cl:logior a b))) + + (define (bits:xor a b) + (lisp ,type (a b) + (cl:logxor a b))) + + (define (bits:not x) + (lisp ,type (x) + (cl:lognot x))) + + (define (bits:shift amount bits) + (lisp ,type (amount bits) + (,handle-overflow (cl:ash bits amount))))))) + + (cl:declaim (cl:inline unsigned-lognot)) + (cl:defun unsigned-lognot (int n-bits) + (cl:declare (cl:type cl:unsigned-byte int) + (cl:type cl:unsigned-byte n-bits) + (cl:values cl:unsigned-byte)) + + (cl:- (cl:ash 1 n-bits) int 1)) + + (cl:declaim (cl:inline handle-unsigned-overflow)) + (cl:defun handle-unsigned-overflow (int n-bits) + (cl:declare (cl:type cl:unsigned-byte int) + (cl:type cl:unsigned-byte n-bits) + (cl:values cl:unsigned-byte)) + + (cl:logand (cl:1- (cl:ash 1 n-bits)) int)) + + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-bits-wrapping (type width) + `(define-instance (bits:Bits ,type) + (define (bits:and a b) + (lisp ,type (a b) + (cl:logand a b))) + + (define (bits:or a b) + (lisp ,type (a b) + (cl:logior a b))) + + (define (bits:xor a b) + (lisp ,type (a b) + (cl:logxor a b))) + + (define (bits:not x) + (lisp ,type (x) + (unsigned-lognot x ,width))) + + (define (bits:shift amount bits) + (lisp ,type (amount bits) + (cl:logand (cl:ash bits amount) + ,(cl:1- (cl:ash 1 width))))))))) -(coalton-toplevel (define-bits-checked Integer cl:identity) (define-bits-checked I8 %handle-8bit-overflow) @@ -433,35 +443,36 @@ (define-bits-wrapping U16 16) (define-bits-wrapping U32 32) (define-bits-wrapping U64 64) - (define-bits-wrapping UFix #.+unsigned-fixnum-bits+)) + (define-bits-wrapping UFix #.+unsigned-fixnum-bits+) + (lisp-toplevel () + ;;; `Hash' instances -(define-sxhash-hasher Integer) -(define-sxhash-hasher I8) -(define-sxhash-hasher I16) -(define-sxhash-hasher I32) -(define-sxhash-hasher I64) -(define-sxhash-hasher U8) -(define-sxhash-hasher U16) -(define-sxhash-hasher U32) -(define-sxhash-hasher U64) -(define-sxhash-hasher IFix) -(define-sxhash-hasher UFix) -(define-sxhash-hasher Single-Float) -(define-sxhash-hasher Double-Float) + (define-sxhash-hasher Integer) + (define-sxhash-hasher I8) + (define-sxhash-hasher I16) + (define-sxhash-hasher I32) + (define-sxhash-hasher I64) + (define-sxhash-hasher U8) + (define-sxhash-hasher U16) + (define-sxhash-hasher U32) + (define-sxhash-hasher U64) + (define-sxhash-hasher IFix) + (define-sxhash-hasher UFix) + (define-sxhash-hasher Single-Float) + (define-sxhash-hasher Double-Float) ;;; ;;; Default instances ;;; -(cl:eval-when (:compile-toplevel :load-toplevel) - (cl:defmacro define-default-num (type) - `(define-instance (Default ,type) - (define (default) 0)))) + (cl:eval-when (:compile-toplevel :load-toplevel) + (cl:defmacro define-default-num (type) + `(define-instance (Default ,type) + (define (default) 0))))) -(coalton-toplevel (define-default-num I8) (define-default-num U8) (define-default-num I16) diff --git a/src/codegen/program.lisp b/src/codegen/program.lisp index 43f37720b..d367be1a4 100644 --- a/src/codegen/program.lisp +++ b/src/codegen/program.lisp @@ -23,6 +23,7 @@ #:optimize-bindings) (:local-nicknames (#:util #:coalton-impl/util) + (#:parser #:coalton-impl/parser) (#:settings #:coalton-impl/settings) (#:global-lexical #:coalton-impl/global-lexical) (#:rt #:coalton-impl/runtime) @@ -42,41 +43,116 @@ A function bound here will be called with a keyword category, and one or more ad Toplevel definitions, after type checking and before compilation.") +;; The following functions control the output order of compiled +;; definitions and interleaved lisp expressions. +;; +;; Toplevel define and instance forms are compiled to 1 or more named, +;; lisp-source-valued output definitions: when these definitions are +;; generated, they are associated with the starting source offset of their +;; toplevel form: +;; +;; toplevel definition: +;; # +;; +;; bindings (lisp definitions): +;; (300 b1 .. bn) +;; +;; Then when compile-definitions emits the full set of output +;; definitions, any lisp source forms that occurred earlier in the +;; file are emitted first. + +(defun bindings-offset (bindings offsets) + "Given a list of binding names, and a name -> offset map, return the earliest binding start offset." + (reduce #'min + (mapcar (lambda (binding) + (gethash (car binding) offsets 0)) + bindings))) + +(defun merge-forms (forms-a forms-b &optional merged) + "Stably merge two lists of forms. + +1. The inputs and output are lists of 2-lists, structured as (OFFSET FORM). +2. The order of both lists is preserved. +3. Lists are merged by recursively selecting the head of the list with the lowest offset. + +Example: + + (merge-forms '((2 \"b\") (8 \"d\") (1 \"a\")) + '((5 \"x\") (7 \"x\"))) + + => ((2 \"b\") (5 \"x\") (7 \"x\") (8 \"d\") (1 \"a\")) + +(Note that the order of elements in the first list is preserved)" + (cond ((endp forms-a) + (return-from merge-forms + (nreconc merged forms-b))) + ((endp forms-b) + (return-from merge-forms + (nreconc merged forms-a))) + ((< (caar forms-a) + (caar forms-b)) + (push (pop forms-a) merged)) + (t + (push (pop forms-b) merged))) + (merge-forms forms-a forms-b merged)) + +(defun compile-definitions (sccs definitions lisp-forms offsets env) + "Compile SCCs and generate a final output definition list, merging any present lisp sources." + (let ((bindings (loop :for scc :in sccs + :for bindings := (remove-if-not (lambda (binding) + (find (car binding) scc)) + definitions) + :collect (cons (bindings-offset bindings offsets) + (compile-scc bindings env)))) + (lisp-forms (mapcar (lambda (lisp-form) + (cons (car (parser:toplevel-lisp-form-source lisp-form)) + (parser:toplevel-lisp-form-body lisp-form))) + lisp-forms))) + (mapcan #'cdr (merge-forms bindings lisp-forms)))) + +(defun definition-bindings (definitions env offsets) + "Translate the DEFINITIONS in this TU into bindings, updating an OFFSETS hashtable to record the source offset of each binding's source definition." + (loop :for define :in definitions + :for offset := (car (tc:toplevel-define-source define)) + :for name := (tc:node-variable-name (tc:toplevel-define-name define)) + :for compiled-node := (translate-toplevel define env name) + + :when *codegen-hook* + :do (funcall *codegen-hook* ':AST + name + (tc:lookup-value-type env name) + (tc:binding-value define)) + + :do (setf (gethash name offsets) offset) + :collect (cons name compiled-node))) + +(defun instance-bindings (instances env offsets) + "Translate the INSTANCES defined by this TU into bindings, updating an OFFSETS hashtable to record the source offset of each binding's source instance." + (loop :for instance :in instances + :for offset := (car (tc:toplevel-define-instance-source instance)) + :for instance-bindings := (translate-instance instance env) + + :do (dolist (binding instance-bindings) + (setf (gethash (car binding) offsets) offset)) + :append instance-bindings)) + (defun compile-translation-unit (translation-unit monomorphize-table env) (declare (type tc:translation-unit translation-unit) (type hash-table monomorphize-table) (type tc:environment env)) - (let* ((definitions + (let* ((offsets (make-hash-table)) + (definitions (append - (loop :for define :in (tc:translation-unit-definitions translation-unit) - :for name := (tc:node-variable-name (tc:toplevel-define-name define)) - - :for compiled-node := (translate-toplevel define env name) - - :do (when *codegen-hook* - (funcall *codegen-hook* - ':AST - name - (tc:lookup-value-type env name) - (tc:binding-value define))) - :collect (cons name compiled-node)) - - ;; HACK: this load bearing reverse should be replaced with an actual solution - (loop :for instance :in (reverse (tc:translation-unit-instances translation-unit)) - :append (translate-instance instance env)))) - - (definition-names - (mapcar #'car definitions))) + (definition-bindings (tc:translation-unit-definitions translation-unit) env offsets) + (instance-bindings (tc:translation-unit-instances translation-unit) env offsets))) + (definition-names (mapcar #'car definitions))) (multiple-value-bind (definitions env) - (optimize-bindings - definitions - monomorphize-table - *package* - env) + (optimize-bindings definitions monomorphize-table *package* env) - (let ((sccs (node-binding-sccs definitions))) + (let ((sccs (node-binding-sccs definitions)) + (lisp-forms (tc:translation-unit-lisp-forms translation-unit))) (values `(progn @@ -103,13 +179,7 @@ A function bound here will be called with a keyword category, and one or more ad (list `(declaim (sb-ext:start-block ,@definition-names)))) - ,@(loop :for scc :in sccs - :for bindings - := (remove-if-not - (lambda (binding) - (find (car binding) scc)) - definitions) - :append (compile-scc bindings env)) + ,@(compile-definitions sccs definitions lisp-forms offsets env) #+sbcl ,@(when (eq sb-ext:*block-compile-default* :specified) diff --git a/src/entry.lisp b/src/entry.lisp index 2b1369301..04c5159de 100644 --- a/src/entry.lisp +++ b/src/entry.lisp @@ -43,53 +43,56 @@ file env) - (multiple-value-bind (class-definitions env) - (tc:toplevel-define-class (parser:program-classes program) - file - env) + (let ((all-instances (append instances (parser:program-instances program)))) + + (multiple-value-bind (class-definitions env) + (tc:toplevel-define-class (parser:program-classes program) + file + env) - (multiple-value-bind (ty-instances env) - (tc:toplevel-define-instance (append instances (parser:program-instances program)) env file) + (multiple-value-bind (ty-instances env) + (tc:toplevel-define-instance all-instances env file) - (multiple-value-bind (toplevel-definitions env) - (tc:toplevel-define (parser:program-defines program) - (parser:program-declares program) - file - env) + (multiple-value-bind (toplevel-definitions env) + (tc:toplevel-define (parser:program-defines program) + (parser:program-declares program) + file + env) - (multiple-value-bind (toplevel-instances) - (tc:toplevel-typecheck-instance ty-instances - (append instances (parser:program-instances program)) - env - file) + (multiple-value-bind (toplevel-instances) + (tc:toplevel-typecheck-instance ty-instances + all-instances + env + file) - (setf env (tc:toplevel-specialize (parser:program-specializations program) env file)) + (setf env (tc:toplevel-specialize (parser:program-specializations program) env file)) - (let ((monomorphize-table (make-hash-table :test #'eq)) + (let ((monomorphize-table (make-hash-table :test #'eq)) - (translation-unit - (tc:make-translation-unit - :types type-definitions - :definitions toplevel-definitions - :classes class-definitions - :instances toplevel-instances - :package *package*))) + (translation-unit + (tc:make-translation-unit + :types type-definitions + :definitions toplevel-definitions + :classes class-definitions + :instances toplevel-instances + :lisp-forms (parser:program-lisp-forms program) + :package *package*))) - (loop :for define :in (parser:program-defines program) - :when (parser:toplevel-define-monomorphize define) - :do (setf (gethash (parser:node-variable-name (parser:toplevel-define-name define)) - monomorphize-table) - t)) + (loop :for define :in (parser:program-defines program) + :when (parser:toplevel-define-monomorphize define) + :do (setf (gethash (parser:node-variable-name (parser:toplevel-define-name define)) + monomorphize-table) + t)) - (loop :for declare :in (parser:program-declares program) - :when (parser:toplevel-declare-monomorphize declare) - :do (setf (gethash (parser:identifier-src-name (parser:toplevel-declare-name declare)) - monomorphize-table) - t)) + (loop :for declare :in (parser:program-declares program) + :when (parser:toplevel-declare-monomorphize declare) + :do (setf (gethash (parser:identifier-src-name (parser:toplevel-declare-name declare)) + monomorphize-table) + t)) - (analysis:analyze-translation-unit translation-unit env file) + (analysis:analyze-translation-unit translation-unit env file) - (codegen:compile-translation-unit translation-unit monomorphize-table env))))))))) + (codegen:compile-translation-unit translation-unit monomorphize-table env)))))))))) (defun expression-entry-point (node file) diff --git a/src/faux-macros.lisp b/src/faux-macros.lisp index 17d5dc5c7..a2ff9a79d 100644 --- a/src/faux-macros.lisp +++ b/src/faux-macros.lisp @@ -45,6 +45,9 @@ (define-coalton-editor-macro coalton:define-instance (instance &body method-definitions) "Define an instance of a type class. (Coalton top-level operator.)") +(define-coalton-editor-macro coalton:lisp-toplevel (options &body lisp-toplevel-forms) + "Include lisp forms. (Coalton top-level operator.)") + (define-coalton-editor-macro coalton:specialize (name from-ty to-ty) "Declare a specialization for a function. (Coalton top-level operator.)") diff --git a/src/package.lisp b/src/package.lisp index 6b0223a40..8e88261ed 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -27,6 +27,7 @@ #:define-class #:define-instance #:repr + #:lisp-toplevel #:monomorphize #:specialize #:unable-to-codegen) diff --git a/src/parser/cursor.lisp b/src/parser/cursor.lisp index ed7f2171f..36a9334e7 100644 --- a/src/parser/cursor.lisp +++ b/src/parser/cursor.lisp @@ -164,22 +164,29 @@ If UNWRAP is NIL, return the CST node, otherwise, return the raw value." "T if NOTE is a help note." (eq ':help (note-type note))) +(defun note->source-note (note) + "Convert NOTE to a source error help note." + (se:make-source-error-note :span (note-span note) + :type (note-type note) + :message (note-text note))) + (defun note->help-note (note) "Convert NOTE to a source error help note." (se:make-source-error-help :span (note-span note) :replacement #'identity :message (note-text note))) -(defun parse-error (file message syntax-error) +(defun parse-error (file message syntax-error &optional notes) "Rethrow SYNTAX-ERROR as a PARSE-ERROR." - (let ((notes (error-notes syntax-error))) + (destructuring-bind (primary-note &rest secondary-notes) + (append (error-notes syntax-error) notes) (error 'parse-error - :err (se:source-error :span (note-span (first notes)) + :err (se:source-error :span (note-span primary-note) :file file :message message - :primary-note (note-text (first notes)) - :notes (remove-if #'help-note-p (rest notes)) + :primary-note (note-text primary-note) + :notes (mapcar #'note->source-note + (remove-if #'help-note-p secondary-notes)) :help-notes (mapcar #'note->help-note - (remove-if-not #'help-note-p - notes)))))) + (remove-if-not #'help-note-p secondary-notes)))))) diff --git a/src/parser/renamer.lisp b/src/parser/renamer.lisp index 3199b6804..173c3497f 100644 --- a/src/parser/renamer.lisp +++ b/src/parser/renamer.lisp @@ -521,6 +521,7 @@ :defines (rename-variables-generic% (program-defines program) ctx) :classes (program-classes program) ; Class type variables are renamed during kind inference :instances (rename-variables-generic% (program-instances program) ctx) + :lisp-forms (program-lisp-forms program) :specializations (program-specializations program) ; Renaming type variables in specializations is not valid ) ctx)) diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index b3585425d..84f4df0d9 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -117,6 +117,11 @@ #:toplevel-define-instance-compiler-generated ; ACCESSOR #:toplevel-define-instance-list ; TYPE #:toplevel-package-name ; ACCESSOR + #:toplevel-lisp-form ; STRUCT + #:make-toplevel-lisp-form ; CONSTRUCTOR + #:toplevel-lisp-form-body ; ACCESSOR + #:toplevel-lisp-form-source ; ACCESSOR + #:toplevel-lisp-form-list ; TYPE #:toplevel-specialize ; STRUCT #:make-toplevel-specialize ; CONSTRUCTOR #:toplevel-specialize-from ; ACCESSOR @@ -128,6 +133,7 @@ #:make-program ; CONSTRUCTOR #:program-package ; ACCESSOR #:program-file ; ACCESSOR + #:program-lisp-forms ; ACCESSOR #:program-types ; ACCESSOR #:program-structs ; ACCESSOR #:program-declares ; ACCESSOR @@ -205,6 +211,8 @@ ;;;; | "(" "define-instance" "(" ty-predicate "=>" ty-predicate ")" docstring? instance-method-definition ")" ;;;; | "(" "define-instance" "(" ( "(" ty-predicate ")" )+ "=>" ty-predicate ")" docstring? instance-method-definition+ ")" ;;;; +;;;; toplevel-lisp-form := "(" "lisp-toplevel" "(" ")" lisp-form* ")" +;;;; ;;;; toplevel-specialize := "(" identifier identifier ty ")" ;; @@ -409,6 +417,19 @@ (deftype toplevel-define-instance-list () '(satisfies toplevel-define-instance-list-p)) +(defstruct (toplevel-lisp-form + (:copier nil)) + (body (util:required 'body) :type cons :read-only t) + (source (util:required 'source) :type cons :read-only t)) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun toplevel-lisp-form-list-p (x) + (and (alexandria:proper-list-p x) + (every #'toplevel-lisp-form-p x)))) + +(deftype toplevel-lisp-form-list () + '(satisfies toplevel-lisp-form-list-p)) + (defstruct (toplevel-specialize (:copier nil)) (from (util:required 'from) :type node-variable :read-only t) @@ -437,13 +458,14 @@ (defstruct (program (:copier nil)) (package (util:required 'package) :type (or null toplevel-package) :read-only t) - (file (util:required 'file) :type se:file :read-only t) + (file (util:required 'file) :type se:file :read-only t) (types (util:required 'types) :type toplevel-define-type-list :read-only nil) (structs (util:required 'structs) :type toplevel-define-struct-list :read-only nil) (declares (util:required 'declares) :type toplevel-declare-list :read-only nil) (defines (util:required 'defines) :type toplevel-define-list :read-only nil) (classes (util:required 'classes) :type toplevel-define-class-list :read-only nil) (instances (util:required 'instances) :type toplevel-define-instance-list :read-only nil) + (lisp-forms (util:required 'lisp-forms) :type toplevel-lisp-form-list :read-only nil) (specializations (util:required 'specializations) :type toplevel-specialize-list :read-only nil)) (defun read-program (stream file &optional mode) @@ -475,6 +497,7 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo :defines nil :classes nil :instances nil + :lisp-forms nil :specializations nil)) (*package* (program-lisp-package program)) @@ -514,6 +537,8 @@ consume all attributes")))) (setf (program-declares program) (nreverse (program-declares program))) (setf (program-defines program) (nreverse (program-defines program))) (setf (program-classes program) (nreverse (program-classes program))) + (setf (program-instances program) (nreverse (program-instances program))) + (setf (program-lisp-forms program) (nreverse (program-lisp-forms program))) (setf (program-specializations program) (nreverse (program-specializations program))) program))) @@ -688,6 +713,45 @@ consume all attributes")))) ;; end package support +(defun eval-toplevel-p (form) + "T if form is an instance of EVAL-WHEN containing a COMPILE-TOPLEVEL symbol." + (and (eq 'cl:eval-when (car form)) + (some (lambda (k) + (or (string-equal 'compile k) + (string-equal 'compile-toplevel k))) + (cadr form)))) + +(defun maybe-def-p (symbol) + "Return T if SYMBOL's name starts with 'DEF'." + (when (symbolp symbol) + (let ((name (symbol-name symbol))) + (and (<= 3 (length name)) + (string= name "DEF" :end1 3))))) + +(defun parse-lisp-toplevel-form (form program) + "Parse lisp forms that are to be literally included in compiler output. + +If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the enclosed forms." + (let* ((options-node (cst:first (cst:rest form))) + (options (cst:raw options-node))) + (unless (null options) + (cond ((maybe-def-p (car options)) + (cursor:span-error + (cst:source (cst:first (cst:rest form))) + "saw 'def' form: in lisp-toplevel, code must be preceded by an empty options list")) + (t + (cursor:span-error + (cst:source (cst:first (cst:rest form))) + "lisp-toplevel must be followed by an empty options list"))))) + + (loop :for form :in (cst:raw (cst:rest (cst:rest form))) + :when (eval-toplevel-p form) + :do (dolist (form (cddr form)) + (eval form))) + (push (make-toplevel-lisp-form :body (cddr (cst:raw form)) + :source (cst:source form)) + (program-lisp-forms program))) + (defun parse-toplevel-form (form program attributes file) (declare (type cst:cst form) (type program program) @@ -746,7 +810,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (node-source (toplevel-define-name define)) :message "when parsing define"))))) @@ -761,11 +825,11 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source monomorphize-form) :message "previous attribute here") (se:make-source-error-note - :type :secondary + :type ':secondary :span (node-source (toplevel-define-name define)) :message "when parsing define"))))) @@ -795,7 +859,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source form) :message "when parsing declare"))))) @@ -810,11 +874,11 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source monomorphize-form) :message "previous attribute here") (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source form) :message "when parsing declare"))))) @@ -845,11 +909,11 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source repr-form) :message "previous attribute here") (se:make-source-error-note - :type :secondary + :type ':secondary :span (toplevel-define-type-head-src type) :message "when parsing define-type"))))) @@ -866,7 +930,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (toplevel-define-type-head-src type) :message "when parsing define-type"))))))) @@ -894,11 +958,11 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source repr-form) :message "previous attribute here") (se:make-source-error-note - :type :secondary + :type ':secondary :span (toplevel-define-struct-head-src struct) :message "when parsing define-struct"))))) @@ -912,7 +976,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (toplevel-define-struct-head-src struct) :message "when parsing define-struct"))))) @@ -929,7 +993,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (identifier-src-source (toplevel-define-struct-name struct)) :message "when parsing define-type"))))))) @@ -951,7 +1015,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (toplevel-define-class-head-src class) :message "while parsing define-class"))))) @@ -971,7 +1035,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (toplevel-define-instance-head-src instance) :message "while parsing define-instance"))))) @@ -979,6 +1043,25 @@ consume all attributes")))) (push instance (program-instances program)) t)) + ((coalton:lisp-toplevel) + (handler-bind ((cursor:syntax-error + (lambda (syntax-error) + (cursor:parse-error file + "Invalid lisp-toplevel form" + syntax-error + (list + (cursor:make-note :span (cst:source form) + :text "when parsing lisp-toplevel" + :type ':secondary)))))) + (unless (alexandria:featurep ':coalton-lisp-toplevel) + (cursor:span-error (cst:source form) + "lisp-toplevel is only allowed in library source code. To enable elsewhere, (pushnew :coalton-lisp-toplevel *features*)")) + (unless (zerop (length attributes)) + (cursor:span-error (cst:source (cdr (aref attributes 0))) + "lisp-toplevel cannot have attributes")) + (parse-lisp-toplevel-form form program)) + t) + ((coalton:specialize) (let ((spec (parse-specialize form file))) @@ -992,7 +1075,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source form) :message "when parsing specialize"))))) @@ -1010,7 +1093,7 @@ consume all attributes")))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source form) :message "when parsing progn"))))) @@ -1031,7 +1114,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source form) :message "when parsing progn"))))) t) @@ -1715,7 +1798,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second form)) :message "in this class definition"))))) @@ -1731,7 +1814,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second form)) :message "in this class definition"))))) @@ -1747,7 +1830,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second form)) :message "in this class definition"))))) @@ -1764,7 +1847,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second form)) :message "in this class definition"))))) @@ -1788,7 +1871,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second form)) :message "in this class definition"))))) @@ -1860,7 +1943,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second enclosing-form)) :message "in this type definition"))))) @@ -1874,7 +1957,7 @@ consume all attributes"))) :notes (list (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source (cst:second enclosing-form)) :message "in this type definition"))))) @@ -1987,7 +2070,7 @@ consume all attributes"))) (let ((context-note (se:make-source-error-note - :type :secondary + :type ':secondary :span (cst:source parent-form) :message "when parsing instance"))) diff --git a/src/typechecker/translation-unit.lisp b/src/typechecker/translation-unit.lisp index d1e622cd4..628b0dc20 100644 --- a/src/typechecker/translation-unit.lisp +++ b/src/typechecker/translation-unit.lisp @@ -8,6 +8,7 @@ #:coalton-impl/typechecker/define-type #:coalton-impl/typechecker/toplevel) (:local-nicknames + (#:parser #:coalton-impl/parser) (#:util #:coalton-impl/util)) (:export #:translation-unit ; STRUCT @@ -15,6 +16,7 @@ #:translation-unit-types ; ACCESSOR #:translation-unit-definitions ; ACCESSOR #:translation-unit-instances ; ACCESSOR + #:translation-unit-lisp-forms ; ACCESSOR #:translation-unit-classes ; ACCESSOR #:translation-unit-attr-table ; ACCESSOR #:translation-unit-package ; ACCESSOR @@ -24,8 +26,9 @@ (in-package #:coalton-impl/typechecker/translation-unit) (defstruct translation-unit - (types nil :type type-definition-list :read-only t) - (definitions nil :type toplevel-define-list :read-only t) - (instances nil :type toplevel-define-instance-list :read-only t) - (classes nil :type ty-class-list :read-only t) - (package (util:required 'package) :type package :read-only t)) + (types nil :type type-definition-list :read-only t) + (definitions nil :type toplevel-define-list :read-only t) + (instances nil :type toplevel-define-instance-list :read-only t) + (lisp-forms (util:required 'lisp-forms) :type parser:toplevel-lisp-form-list :read-only t) + (classes nil :type ty-class-list :read-only t) + (package (util:required 'package) :type package :read-only t)) diff --git a/tests/parser-test-files/lisp-toplevel-forbid.txt b/tests/parser-test-files/lisp-toplevel-forbid.txt new file mode 100644 index 000000000..01c5a3bbe --- /dev/null +++ b/tests/parser-test-files/lisp-toplevel-forbid.txt @@ -0,0 +1,20 @@ +================================================================================ +Forbid outside of library code +================================================================================ + +(package test) + +(lisp-toplevel + (defvar *x* nil)) + +-------------------------------------------------------------------------------- + +error: Invalid lisp-toplevel form + --> test:3:0 + | + 3 | (lisp-toplevel + | __^ + | | _- + 4 | || (defvar *x* nil)) + | ||___________________- when parsing lisp-toplevel + | |____________________^ lisp-toplevel is only allowed in library source code. To enable elsewhere, (pushnew :coalton-lisp-toplevel *features*) diff --git a/tests/parser-test-files/lisp-toplevel.txt b/tests/parser-test-files/lisp-toplevel.txt new file mode 100644 index 000000000..1448ad074 --- /dev/null +++ b/tests/parser-test-files/lisp-toplevel.txt @@ -0,0 +1,64 @@ +================================================================================ +Empty options + +To support future extension, lisp-toplevel expects an empty options list in the +first poisition. +================================================================================ + +(package test) + +(lisp-toplevel (x) + t) + +-------------------------------------------------------------------------------- + +error: Invalid lisp-toplevel form + --> test:3:15 + | + 3 | (lisp-toplevel (x) + | _- + | | ^^^ lisp-toplevel must be followed by an empty options list + 4 | | t) + | |____- when parsing lisp-toplevel + +================================================================================ +lisp-toplevel must receive an options list +================================================================================ + +(package test) + +(lisp-toplevel + (defvar *x* nil)) + +-------------------------------------------------------------------------------- + +error: Invalid lisp-toplevel form + --> test:4:2 + | + 3 | (lisp-toplevel + | _- + 4 | | (defvar *x* nil)) + | | ^^^^^^^^^^^^^^^^ saw 'def' form: in lisp-toplevel, code must be preceded by an empty options list + | |___________________- when parsing lisp-toplevel + +================================================================================ +lisp-toplevel may not have attributes +================================================================================ + +(package test) + +(repr :lisp) +(lisp-toplevel + (defvar *x* nil)) + +-------------------------------------------------------------------------------- + +error: Invalid lisp-toplevel form + --> test:3:0 + | + 3 | (repr :lisp) + | ^^^^^^^^^^^^ lisp-toplevel cannot have attributes + 4 | (lisp-toplevel + | _- + 5 | | (defvar *x* nil)) + | |___________________- when parsing lisp-toplevel diff --git a/tests/parser-tests.lisp b/tests/parser-tests.lisp index 376610a57..5f8784bf4 100644 --- a/tests/parser-tests.lisp +++ b/tests/parser-tests.lisp @@ -44,4 +44,7 @@ (parse-file file)))) (deftest test-parse-package-suite () + (let ((*features* (cons ':coalton-lisp-toplevel *features*))) + (run-suite "tests/parser-test-files/lisp-toplevel.txt")) + (run-suite "tests/parser-test-files/lisp-toplevel-forbid.txt") (run-suite "tests/parser-test-files/package.txt"))