diff --git a/src/analysis/analysis.lisp b/src/analysis/analysis.lisp index 2bda8422..f677820b 100644 --- a/src/analysis/analysis.lisp +++ b/src/analysis/analysis.lisp @@ -25,8 +25,8 @@ (let ((missing (find-non-matching-value (list (list pattern)) 1 env))) (unless (eq t missing) (tc-error "Non-exhaustive match" - (source:note pattern "missing case ~w" - (print-pattern (first missing))))))) + (source:secondary-note pattern "missing case ~w" + (print-pattern (first missing))))))) (defun analyze-translation-unit (translation-unit env) "Perform analysis passes on TRANSLATION-UNIT, potentially producing errors or warnings." @@ -47,9 +47,9 @@ (cons (source:note node "non-exhaustive match") (when (first exhaustive-or-missing) (list - (source:note node "missing case ~w" - (print-pattern - (first exhaustive-or-missing)))))))) + (source:secondary-note node "missing case ~w" + (print-pattern + (first exhaustive-or-missing)))))))) (loop :for pattern :in patterns :unless (useful-pattern-p patterns pattern env) :do (source:warn "Useless match case" diff --git a/src/doc/markdown.lisp b/src/doc/markdown.lisp index 722963ce..05ee8de9 100644 --- a/src/doc/markdown.lisp +++ b/src/doc/markdown.lisp @@ -87,12 +87,12 @@ :do (incf index))) (defun line-number (backend source offset) - (let ((line-offsets (gethash (source-error:source-name source) + (let ((line-offsets (gethash (source:source-name source) (slot-value backend 'file-line-offsets)))) (unless line-offsets - (with-open-stream (stream (source-error:source-stream source)) + (with-open-stream (stream (source:source-stream source)) (setf line-offsets (find-line-offsets stream))) - (setf (gethash (source-error:source-name source) + (setf (gethash (source:source-name source) (slot-value backend 'file-line-offsets)) line-offsets)) (labels ((%find (lo hi) diff --git a/src/doc/model.lisp b/src/doc/model.lisp index 1911e2d8..fb9b96a3 100644 --- a/src/doc/model.lisp +++ b/src/doc/model.lisp @@ -87,16 +87,15 @@ (source:location-source location)))) (defun source-available-p (object) - (let ((source (source object))) - (and source - (not (null (source-error:source-name source)))))) + (and (source object) + (source:source-available-p (source object)))) (defun source-location-href (object) (when (source-available-p object) (format nil "~a/~a" *remote* (remove-prefix (ensure-suffix #\/ *local*) - (source-error:source-name (source object)))))) + (source:source-name (source object)))))) (defun source-span (object) (source:location-span (object-location object))) diff --git a/src/entry.lisp b/src/entry.lisp index 61349d67..919e0cb0 100644 --- a/src/entry.lisp +++ b/src/entry.lisp @@ -4,7 +4,6 @@ (:shadow #:compile) (:local-nicknames - (#:se #:source-error) (#:settings #:coalton-impl/settings) (#:util #:coalton-impl/util) (#:parser #:coalton-impl/parser) @@ -221,7 +220,7 @@ (defun compile-to-lisp (source output) "Read Coalton source from SOURCE and write Lisp source to OUTPUT. NAME may be the filename related to the input stream." (declare (optimize (debug 3))) - (with-open-stream (stream (se:source-stream source)) + (with-open-stream (stream (source:source-stream source)) (parser:with-reader-context stream (with-environment-updates updates (let* ((program (parser:read-program stream source ':file)) diff --git a/src/parser/base.lisp b/src/parser/base.lisp index b3a25a7c..101ed9d3 100644 --- a/src/parser/base.lisp +++ b/src/parser/base.lisp @@ -5,7 +5,6 @@ #:parse-error) (:local-nicknames (#:cst #:concrete-syntax-tree) - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util)) (:export @@ -23,6 +22,7 @@ #:parse-list ; FUNCTION #:parse-error #:note + #:secondary-note #:note-end #:help #:form-location)) @@ -95,13 +95,13 @@ ;;; (note SOURCE CST2 "Related: ~A" ARG3) ;;; ... ) -(define-condition parse-error (se:source-base-error) +(define-condition parse-error (source:source-error) () (:documentation "A condition indicating a syntax error in Coalton source code.")) (defun parse-error (message &rest notes) "Signal PARSE-ERROR with provided MESSAGE and source NOTES." - (error 'parse-error :err (source:make-source-error ':error message notes))) + (error 'parse-error :message message :notes notes)) (defun ensure-span (spanning) "Is SPANNING is a span, return it unchanged; if it is a cst node, return the node's span." @@ -115,6 +115,12 @@ (apply #'source:note (source:make-location source (ensure-span locatable)) format-string format-args)) +(defun secondary-note (source locatable format-string &rest format-args) + "Make a source note using SOURCE and CST:SOURCE as location." + (declare (type string format-string)) + (apply #'source:secondary-note (source:make-location source (ensure-span locatable)) + format-string format-args)) + (defun note-end (source locatable format-string &rest format-args) "Make a source note using SOURCE and the location immediately following CST:SOURCE as location." (apply #'source:note diff --git a/src/parser/cursor.lisp b/src/parser/cursor.lisp index ab0cb8d1..0552ea2f 100644 --- a/src/parser/cursor.lisp +++ b/src/parser/cursor.lisp @@ -1,13 +1,23 @@ -;;; This package provides utilities for incremental consumption of -;;; concrete syntax tree values. A cursor struct maintains a -;;; reference to the current value and a pointer within it, if it is -;;; cons-valued. The functions 'next' and 'empty-p' are sufficient to -;;; build more specialized parsing functions that don't need knowledge -;;; of the cst package. +;;;; Utilities for incremental consumption of concrete syntax tree +;;;; values. A cursor maintains a reference to a value, and optionally +;;;; to a position within it, if it is cons-valued. The functions +;;;; 'next' and 'empty-p' are sufficient to build specialized parsing +;;;; functions that don't need knowledge of the cst package. +;;;; +;;;; Example of a parser for expressions like "(sym* -> sym*)" +;;;; +;;;; (let* ((cursor (cursor:make-cursor form source "invalid")) +;;;; (left (cursor:collect cursor +;;;; :test (lambda (sym) (not (eq sym '->)))))) +;;;; (cursor:discard-symbol cursor) ; discard separator +;;;; (let ((right (cursor:collect cursor))) +;;;; (cons left right))) (defpackage #:coalton-impl/parser/cursor (:use #:cl) + (:shadow + #:error) (:local-nicknames (#:cst #:concrete-syntax-tree) (#:source #:coalton-impl/source) @@ -16,31 +26,35 @@ #:coalton-impl/parser/base #:parse-error) (:export + #:atom-p + #:collect #:collect-symbols #:cursor-location #:cursor-message + #:cursor-pointer #:cursor-source #:cursor-value - #:do-every + #:discard-symbol + #:each #:empty-p + #:error #:make-cursor #:next #:next-symbol - #:parse-error - #:peek - #:syntax-error)) + #:peek)) (in-package #:coalton-impl/parser/cursor) -;; The value field can be any type returned by cst, generally a cons -;; or atom. When value is a cst:cons, pointer initially points to -;; that value, and is destructively updated as values are 'popped'. +;;; The value field can be any type returned by cst, generally a cons +;;; or atom. When value is a cst:cons, pointer initially points to +;;; that value, and is destructively updated as values are 'popped'. (defstruct (cursor (:constructor %make-cursor)) "A CST node-valued cursor." (value (util:required 'value) :type cst:cst) ; current value (pointer (util:required 'value) :type cst:cst) ; pointer into current value - (source (util:required 'source) ) ; the source:location of cursor + (last nil :type (or null cst:cst)) ; pointer to most recently consumed value + (source (util:required 'source)) ; the source:location of cursor (message (util:required 'message) :type string)) ; a message providing context for errors ;;; The implementation of source:location for a cursor returns the @@ -57,15 +71,22 @@ :source source :message message)) -(defun peek (cursor) - "Peek at the Lisp value of CURSOR without changing cursor state." - (cst:raw (cursor-pointer cursor))) - -(defun cons-p (cursor) - "T if CURSOR is pointing at a cons." +(defun peek (cursor &key (unwrap t)) + "Peek at the value of CURSOR without changing any state." (declare (type cursor cursor)) - (or (cst:consp (cursor-pointer cursor)) - (null (peek cursor)))) + (unless (empty-p cursor) + (let ((value (cst:first (cursor-pointer cursor)))) + (when unwrap + (setf value (cst:raw value))) + value))) + +(defun atom-p (cursor) + "Return T if cursor is pointing at an atom." + (cst:atom (cursor-pointer cursor))) + +(defun proper-list-p (cursor) + "Return T if cursor is pointing at a proper list." + (cst:proper-list-p (cursor-pointer cursor))) (defun empty-p (cursor) "T if CURSOR has no next value." @@ -74,38 +95,42 @@ (or (not (cst:consp pointer)) (null (cst:first pointer))))) -(defun cursor-span (cursor) - "Return the span that CURSOR is pointing at. - -If the wrapped node pointed to a non-empty cons, the span is the first value. -If the node is empty, the span is empty and points at the end of the wrapped value. -Otherwise, the span is the cst:source of the wrapped node." - - (declare (type cursor cursor)) - (let ((pointer (cursor-pointer cursor)) - (cons-p (cons-p cursor)) - (empty-p (empty-p cursor))) - (cond ((and cons-p (not empty-p)) - (cst:source (cst:first pointer))) - (cons-p - (cons (1- (cdr (cst:source pointer))) - (cdr (cst:source pointer)))) - (t - (cst:source pointer))))) - (defun cursor-location (cursor) "Return the location of the value that CURSOR is pointing at." (source:make-location (cursor-source cursor) - (cursor-span cursor))) - -(defun syntax-error (cursor note &key (end nil)) - "Signal a PARSE-ERROR related to the current value of a cursor. -If END is T, indicate the location directly following the current value." - (let ((location (if end - (source:end-location (cursor-location cursor)) - (cursor-location cursor)))) - (parse-error (cursor-message cursor) - (source:note location note)))) + (cond ((cursor-last cursor) + (cst:source (cursor-last cursor))) + (t + (let ((s (cst:source (cursor-value cursor)))) + (cons (1+ (car s)) + (1+ (car s)))))))) + +(defun %label-location (cursor position) + "Look up the CURSOR-relative error message location for a symbolic POSITION." + (ecase position + (:last + (cursor-location cursor)) + (:next + (source:make-location (cursor-source cursor) + (cst:source (cst:first (cursor-pointer cursor))))) + (:form + (source:make-location (cursor-source cursor) + (cst:source (cursor-value cursor)))) + (:after-last + (source:end-location (cursor-location cursor))))) + + +(defun error (cursor position note) + "Signal a PARSE-ERROR with a NOTE that labels the current value of a cursor. + +Position is one of: + +:last -- label the last element +:next -- label the next element +:form -- label the enclosing form +:after-last -- point just past the last element" + (parse-error (cursor-message cursor) + (source:note (%label-location cursor position) note))) (defun next (cursor &key (pred nil) (unwrap t)) "Return the next value from a nonempty cursor. @@ -113,50 +138,71 @@ If END is T, indicate the location directly following the current value." If PRED is non-NIL, only consume a value if it is true. If UNWRAP is NIL, return the CST node, otherwise, return the raw value." (declare (type cursor cursor)) - (when (not (cons-p cursor)) - (syntax-error cursor "not a list")) (when (empty-p cursor) ;; Finding empty-p = t here this would indicate that the compiler ;; writer hasn't checked for emptiness in the calling context in ;; order to construct a more specific error message. - (syntax-error cursor "attempt to read past end of list")) + (error cursor ':after-last "attempt to read past end of list")) (let ((value (cst:first (cursor-pointer cursor)))) (when (or (null pred) (funcall pred (cst:raw value))) (setf (cursor-pointer cursor) - (cst:rest (cursor-pointer cursor))) + (cst:rest (cursor-pointer cursor)) + (cursor-last cursor) + value) (if unwrap (cst:raw value) value)))) -(defun do-every (cursor fn) - "Wrap each value in CURSOR in a subcursor, and call FN with it." +(defun %ensure-proper-list (cursor) + "Enforce that CURSOR points at a proper list before iterating. Empty lists are allowed." + (unless (null (cst:raw (cursor-pointer cursor))) + (when (atom-p cursor) + (error cursor ':form "expected a list")) + (unless (proper-list-p cursor) + (error cursor ':form "unexpected dotted list")))) + +(defun each (cursor f) + "For each element in cons-valued CURSOR, create a subcursor and apply F." + (%ensure-proper-list cursor) (loop :until (empty-p cursor) - :do (funcall fn (make-cursor (next cursor :unwrap nil) - (cursor-source cursor) - (cursor-message cursor))))) - -(defun next-symbol (cursor &key message missing require) - "Return the next value in CURSOR as a symbol. The cursor must be nonempty, and the next value must be a symbol." + :do (let ((value (next cursor :unwrap nil))) + (funcall f (%make-cursor :value value + :pointer value + :source (cursor-source cursor) + :message (cursor-message cursor)))))) + +(defun collect (cursor &key test (key #'identity)) + "Collect values from list-valued CURSOR until empty or TEST returns NIL, optionally transforming each value with KEY." + (%ensure-proper-list cursor) + (loop :until (or (empty-p cursor) + (and test (not (funcall test (peek cursor))))) + :collect (funcall key (next cursor :unwrap nil)))) + +;;; Utilities for reading symbols + +(defun next-symbol (cursor missing not-symbol) + "Return the next symbol in cursor. +If the cursor is empty, signal an error with MISSING as the message. +If the next element is not a symbol, signal an error with NOT-SYMBOL as the message." (when (empty-p cursor) - ;; When empty, indicate the character immediately preceding the - ;; end of the cursor's outside span. - (let ((end (1- (source:span-end (source:location-span (source:location cursor)))))) - (parse-error (cursor-message cursor) - (source:note (source:make-location (cursor-source cursor) - (cons end end)) - (or missing "symbol is missing"))))) - (next cursor - :pred (lambda (value) - (when (or (null value) - (not (symbolp value))) - (syntax-error cursor - (or message "value must be a symbol"))) - (when (and require (not (string-equal require value))) - (syntax-error cursor - (or message - (format nil "expected ~A" require)))) - t))) + (error cursor ':after-last missing)) + (let ((name (next cursor))) + (unless (symbolp name) + (error cursor ':last not-symbol)) + name)) + +(defun discard-symbol (cursor &optional symbol message) + "Read and discard a symbol from CURSOR. +Signal a condition with MESSAGE if a symbol is not present." + (let ((s (next-symbol cursor (or message (format nil "expected ~A" symbol)) + (or message "must be a symbol")))) + (when (and symbol (not (string-equal s symbol))) + (error cursor ':last (or message (format nil "expected ~A" symbol)))) + s)) (defun collect-symbols (cursor) - "Return all remaining values in CURSOR as a list of symbols." - (loop :until (empty-p cursor) - :collect (next-symbol cursor))) + "Read a list of symbols from CURSOR." + (collect cursor + :test (lambda (value) + (or (and value (symbolp value)) + (error cursor ':next "expected symbol"))) + :key #'cst:raw)) diff --git a/src/parser/expression.lisp b/src/parser/expression.lisp index 86f50085..3c749869 100644 --- a/src/parser/expression.lisp +++ b/src/parser/expression.lisp @@ -10,7 +10,6 @@ #:parse-error) (:local-nicknames (#:cst #:concrete-syntax-tree) - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) (#:const #:coalton-impl/constants)) @@ -589,7 +588,6 @@ Rebound to NIL parsing an anonymous FN.") ;; Keywords ;; - ((and (cst:atom (cst:first form)) (eq 'coalton:fn (cst:raw (cst:first form)))) (let ((params) @@ -598,12 +596,12 @@ Rebound to NIL parsing an anonymous FN.") ;; (fn) (unless (cst:consp (cst:rest form)) (parse-error "Malformed function" - (note-end source form "expected function arguments"))) + (note-end source (cst:first form) "expected function arguments"))) ;; (fn (...)) (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed function" - (note-end source form "expected function body"))) + (note-end source (cst:second form) "expected function body"))) ;; (fn x ...) ;; @@ -636,19 +634,19 @@ Rebound to NIL parsing an anonymous FN.") ;; (let) (unless (cst:consp (cst:rest form)) (parse-error "Malformed let" - (note-end source form "expected let binding list"))) + (note-end source (cst:first form) "expected let binding list"))) ;; (let (...)) (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed let" - (note-end source form "expected let body"))) + (note-end source (cst:second form) "expected let body"))) (unless (cst:proper-list-p (cst:second form)) (parse-error "Malformed let" (note source (cst:second form) "expected binding list"))) (let* (declares - + (bindings (loop :for bindings := (cst:second form) :then (cst:rest bindings) :while (cst:consp bindings) :for binding := (cst:first bindings) @@ -673,12 +671,12 @@ Rebound to NIL parsing an anonymous FN.") ;; (lisp) (unless (cst:consp (cst:rest form)) (parse-error "Malformed lisp expression" - (note-end source form "expected expression type"))) + (note-end source (cst:first form) "expected expression type"))) ;; (lisp T) (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed lisp expression" - (note-end source form "expected binding list"))) + (note-end source (cst:second form) "expected binding list"))) ;; (lisp T (...)) (unless (cst:consp (cst:rest (cst:rest (cst:rest form)))) @@ -701,7 +699,7 @@ Rebound to NIL parsing an anonymous FN.") ;; (match) (unless (cst:consp (cst:rest form)) (parse-error "Malformed match expression" - (note-end source form "expected expression"))) + (note-end source (cst:first form) "expected expression"))) (make-node-match :expr (parse-expression (cst:second form) source) @@ -713,7 +711,7 @@ Rebound to NIL parsing an anonymous FN.") ((and (cst:atom (cst:first form)) (eq 'coalton:progn (cst:raw (cst:first form)))) (make-node-progn - :body (parse-body (cst:rest form) form source) + :body (parse-body (cst:rest form) (cst:first form) source) :location (form-location source form))) ((and (cst:atom (cst:first form)) @@ -721,12 +719,12 @@ Rebound to NIL parsing an anonymous FN.") ;; (the) (unless (cst:consp (cst:rest form)) (parse-error "Malformed the expression" - (note-end source form "expected type"))) + (note-end source (cst:first form) "expected type"))) ;; (the T) (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed the expression" - (note-end source form "expected value"))) + (note-end source (cst:second form) "expected value"))) ;; (the a b c) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) @@ -761,7 +759,7 @@ Rebound to NIL parsing an anonymous FN.") (eq 'coalton:or (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) (parse-error "Malformed or expression" - (note-end source form "expected one or more arguments"))) + (note-end source (cst:first form) "expected one or more arguments"))) (make-node-or :nodes (loop :for args := (cst:rest form) :then (cst:rest args) @@ -774,7 +772,7 @@ Rebound to NIL parsing an anonymous FN.") (eq 'coalton:and (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) (parse-error "Malformed and expression" - (note-end source form "expected one or more arguments"))) + (note-end source (cst:first form) "expected one or more arguments"))) (make-node-and :nodes (loop :for args := (cst:rest form) :then (cst:rest args) @@ -787,20 +785,20 @@ Rebound to NIL parsing an anonymous FN.") (eq 'coalton:if (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) (parse-error "Malformed if expression" - (note-end source form "expected a predicate"))) + (note-end source (cst:first form) "expected a predicate"))) (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed if expression" - (note-end source form "expected a form"))) + (note-end source (cst:second form) "expected a form"))) (unless (cst:consp (cst:rest (cst:rest (cst:rest form)))) (parse-error "Malformed if expression" - (note-end source form "expected a form"))) + (note-end source (cst:third form) "expected a form"))) (when (cst:consp (cst:rest (cst:rest (cst:rest (cst:rest form))))) (parse-error "Malformed if expression" - (note-end source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form))))) - "unexpected trailing form"))) + (note source (cst:first (cst:rest (cst:rest (cst:rest (cst:rest form))))) + "unexpected trailing form"))) (make-node-if :expr (parse-expression (cst:second form) source) @@ -812,29 +810,29 @@ Rebound to NIL parsing an anonymous FN.") (eq 'coalton:when (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) (parse-error "Malformed when expression" - (note-end source form "expected a predicate"))) + (note-end source (cst:first form) "expected a predicate"))) (make-node-when :expr (parse-expression (cst:second form) source) - :body (parse-body (cst:rest (cst:rest form)) form source) + :body (parse-body (cst:rest (cst:rest form)) (cst:second form) source) :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:unless (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) (parse-error "Malformed unless expression" - (note-end source form "expected a predicate"))) + (note-end source (cst:first form) "expected a predicate"))) (make-node-unless :expr (parse-expression (cst:second form) source) - :body (parse-body (cst:rest (cst:rest form)) form source) + :body (parse-body (cst:rest (cst:rest form)) (cst:second form) source) :location (form-location source form))) ((and (cst:atom (cst:first form)) (eq 'coalton:cond (cst:raw (cst:first form)))) (unless (cst:consp (cst:rest form)) (parse-error "Malformed cond expression" - (note-end source form "expected one or more clauses"))) + (note-end source (cst:first form) "expected one or more clauses"))) (make-node-cond :clauses (loop :for clauses := (cst:rest form) :then (cst:rest clauses) @@ -849,16 +847,15 @@ Rebound to NIL parsing an anonymous FN.") ((and (cst:atom (cst:first form)) (eq 'coalton:while (cst:raw (cst:first form)))) - - (multiple-value-bind (label labelled-body) (take-label form) + (multiple-value-bind (label labelled-body label-cst) (take-label form) ;; (while [label]) (unless (cst:consp labelled-body) (parse-error "Malformed while expression" - (note-end source form "expected condition"))) + (note-end source (or label-cst (cst:first form)) "expected condition"))) ;; (while [label] condition) (unless (cst:consp (cst:rest labelled-body)) (parse-error "Malformed while expression" - (note-end source form "expected body"))) + (note-end source (cst:first labelled-body) "expected body"))) (let ((*loop-label-context* (if label (list* label const:+default-loop-label+ *loop-label-context*) @@ -873,27 +870,29 @@ Rebound to NIL parsing an anonymous FN.") ((and (cst:atom (cst:first form)) (eq 'coalton:while-let (cst:raw (cst:first form)))) - (multiple-value-bind (label labelled-body) (take-label form) + (multiple-value-bind (label labelled-body label-cst) (take-label form) ;; (while-let [label]) (unless (cst:consp labelled-body) (parse-error "Malformed while-let expression" - (note-end source form "expected pattern"))) + (note-end source (or label-cst (cst:first form)) "expected pattern"))) ;; (while-let [label] pattern) (unless (and (cst:consp (cst:rest labelled-body)) (eq 'coalton:= (cst:raw (cst:second labelled-body)))) (parse-error "Malformed while-let expression" - (note-end source form "expected ="))) + (if (cst:consp (cst:rest labelled-body)) + (note source (cst:second labelled-body) "expected =") + (note-end source (cst:first labelled-body) "expected =")))) ;; (when-let [label] pattern =) (unless (cst:consp (cst:nthrest 2 labelled-body)) (parse-error "Malformed while-let expression" - (note-end source form "expected expression"))) + (note-end source (cst:second labelled-body) "expected expression"))) ;; (when-let pattern = expr) (unless (cst:consp (cst:nthrest 3 labelled-body)) (parse-error "Malformed while-let expression" - (note-end source form "expected body"))) + (note-end source (cst:third labelled-body) "expected body"))) (let* ((*loop-label-context* (if label (list* label const:+default-loop-label+ *loop-label-context*) @@ -907,10 +906,10 @@ Rebound to NIL parsing an anonymous FN.") ((and (cst:atom (cst:first form)) (eq 'coalton:loop (cst:raw (cst:first form)))) - (multiple-value-bind (label labelled-body) (take-label form) + (multiple-value-bind (label labelled-body label-cst) (take-label form) (unless (cst:consp labelled-body) (parse-error "Malformed loop expression" - (note-end source form "expected a loop body"))) + (note-end source (or label-cst (cst:first form)) "expected a loop body"))) (let* ((*loop-label-context* (if label @@ -973,18 +972,21 @@ Rebound to NIL parsing an anonymous FN.") ((and (cst:atom (cst:first form)) (eq 'coalton:for (cst:raw (cst:first form)))) - (multiple-value-bind (label labelled-body) (take-label form) + (multiple-value-bind (label labelled-body label-cst) (take-label form) ;; (for [label]) (unless (cst:consp labelled-body) (parse-error "Malformed for expression" - (note-end source form "expected pattern"))) + (note-end source (or label-cst (cst:first form)) "expected pattern"))) ;; (for [label] pattern) (unless (and (cst:consp (cst:rest labelled-body)) (cst:atom (cst:second labelled-body)) (eq 'coalton:in (cst:raw (cst:second labelled-body)))) (parse-error "Malformed for expression" - (note-end source form "expected in"))) + (if (and (cst:consp (cst:rest labelled-body)) + (cst:second labelled-body)) + (note source (cst:second labelled-body) "expected in") + (note-end source (cst:first labelled-body) "expected in")))) ;; (for [label] pattern in) (unless (cst:consp (cst:nthrest 2 labelled-body)) @@ -994,7 +996,7 @@ Rebound to NIL parsing an anonymous FN.") ;; (for [label] pattern in expr) (unless (cst:consp (cst:nthrest 3 labelled-body)) (parse-error "Malformed for expression" - (note-end source form "expected body"))) + (note-end source (cst:third labelled-body) "expected body"))) (let ((*loop-label-context* (if label @@ -1021,11 +1023,8 @@ Rebound to NIL parsing an anonymous FN.") (parse-error "Invalid macro expansion" (note source form "macro expansion limit hit"))) - (let ((se:*source-error-context* - (adjoin (se:make-source-error-context - :message "Error occurs within macro context. Source locations may be imprecise") - se:*source-error-context* - :test #'equalp))) + (source:with-context + (:macro "Error occurs within macro context. Source locations may be imprecise") (parse-expression (expand-macro form source) source)))) ;; @@ -1095,13 +1094,13 @@ Rebound to NIL parsing an anonymous FN.") (parse-error "Invalid literal" (note source form "unknown literal type"))))) -(defun parse-body (form enclosing-form source) +(defun parse-body (form preceding-form source) (declare (type cst:cst form) (values node-body &optional)) (when (cst:atom form) (parse-error "Malformed function" - (note-end source enclosing-form "expected body"))) + (note-end source preceding-form "expected body"))) (assert (cst:proper-list-p form)) @@ -1208,7 +1207,7 @@ Rebound to NIL parsing an anonymous FN.") ;; (x) (unless (cst:consp (cst:rest form)) (parse-error "Malformed let binding" - (note-end source form + (note-end source (cst:first form) "let bindings must have a value"))) ;; (a b c ...) @@ -1237,7 +1236,7 @@ Rebound to NIL parsing an anonymous FN.") ;; (P) (unless (cst:consp (cst:rest form)) (parse-error "Malformed match branch" - (note-end source form "expected body"))) + (note-end source (cst:first form) "expected body"))) (make-node-match-branch :pattern (parse-pattern (cst:first form) source) @@ -1258,7 +1257,7 @@ Rebound to NIL parsing an anonymous FN.") (make-node-cond-clause :expr (parse-expression (cst:first form) source) - :body (parse-body (cst:rest form) form source) + :body (parse-body (cst:rest form) (cst:first form) source) :location (form-location source form))) (defun parse-do (form source) @@ -1268,7 +1267,7 @@ Rebound to NIL parsing an anonymous FN.") (unless (cst:consp (cst:rest form)) (parse-error "Malformed do expression" - (note-end source form "expected one or more forms"))) + (note-end source (cst:first form) "expected one or more forms"))) (let* (last-node @@ -1350,13 +1349,13 @@ Rebound to NIL parsing an anonymous FN.") (parse-error "Malformed do expression" (note source form "do expressions cannot be terminated by a shorthand let") - (note source parent-form "when parsing do expression"))) + (secondary-note source parent-form "when parsing do expression"))) (when (do-bind-p form) (parse-error "Malformed do expression" (note source form "do expression cannot be terminated by a bind") - (note source parent-form "when parsing do expression"))) + (secondary-note source parent-form "when parsing do expression"))) (parse-expression form source)) @@ -1381,14 +1380,14 @@ Rebound to NIL parsing an anonymous FN.") :location (form-location source form))) (defun take-label (form) - "Takes form (HEAD . (MAYBEKEYWORD . REST)) and returns two values, + "Takes form (HEAD . (MAYBEKEYWORD . REST)) and returns three values, either -MAYBEKEYWORD REST +MAYBEKEYWORD REST MAYBECST if MAYBEKEYWORD is a keyword, or else -NIL (MAYBEKEYWORD . REST) +NIL (MAYBEKEYWORD . REST) NIL if (CST:SECOND FORM) is not a keyword." (declare (type cst:cst form) @@ -1397,5 +1396,6 @@ if (CST:SECOND FORM) is not a keyword." (cst:atom (cst:second form)) (keywordp (cst:raw (cst:second form)))) (values (cst:raw (cst:second form)) - (cst:nthrest 2 form)) - (values nil (cst:rest form)))) + (cst:nthrest 2 form) + (cst:second form)) + (values nil (cst:rest form) nil))) diff --git a/src/parser/pattern.lisp b/src/parser/pattern.lisp index f5f6fee6..af62695e 100644 --- a/src/parser/pattern.lisp +++ b/src/parser/pattern.lisp @@ -7,7 +7,6 @@ #:parse-error) (:local-nicknames (#:cst #:concrete-syntax-tree) - (#:se #:source-error) (#:source #:coalton-impl/source) (#:util #:coalton-impl/util)) (:export diff --git a/src/parser/toplevel.lisp b/src/parser/toplevel.lisp index 9d817457..10ae7022 100644 --- a/src/parser/toplevel.lisp +++ b/src/parser/toplevel.lisp @@ -14,8 +14,6 @@ (#:cst #:concrete-syntax-tree) (#:cursor #:coalton-impl/parser/cursor) (#:source #:coalton-impl/source) - (#:se #:source-error) - (#:source #:coalton-impl/source) (#:util #:coalton-impl/util)) (:export #:attribute ; TYPE @@ -505,9 +503,9 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (when (and eofp (eq mode ':macro)) (parse-error "Unexpected EOF" - (source:note (source:make-location source (cons (- (file-position stream) 2) - (- (file-position stream) 1))) - "missing close parenthesis"))) + (note source (cons (- (file-position stream) 2) + (- (file-position stream) 1)) + "missing close parenthesis"))) (unless presentp (return)) @@ -543,9 +541,9 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (unless presentp (parse-error "Malformed coalton expression" - (source:note (source:make-location source (cons (- (file-position stream) 2) - (- (file-position stream) 1))) - "missing expression"))) + (note source (cons (- (file-position stream) 2) + (- (file-position stream) 1)) + "missing expression"))) ;; Ensure there is only one form (multiple-value-bind (form presentp) @@ -560,23 +558,25 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo ;;; Packages (defun parse-import-statement (package cursor) - (typecase (cursor:peek cursor) + (typecase (cst:raw (cursor:cursor-pointer cursor)) (list (let ((name (cursor:next-symbol cursor - :message "package name must be a symbol" - :missing "package name is missing"))) - (cursor:next-symbol cursor :require "AS" - :missing "missing AS") + "package name is missing" + "package name must be a symbol"))) + (cursor:discard-symbol cursor 'as) (let ((nick (cursor:next-symbol cursor - :message "package nickname msut be a symbol" - :missing "missing package nickname"))) + "missing package nickname" + "package nickname msut be a symbol"))) (when (not (cursor:empty-p cursor)) - (cursor:syntax-error cursor "unexpected value")) + (cursor:error cursor ':next "unexpected value")) (pushnew (list (symbol-name nick) (symbol-name name)) (toplevel-package-import-as package))))) (symbol (pushnew (symbol-name (cst:raw (cursor:cursor-value cursor))) (toplevel-package-import package))) - (t (cursor:syntax-error cursor "expected PACKAGE or (PACKAGE as NICK)")))) + (t (parse-error "Malformed package declaration" + (note (cursor:cursor-source cursor) + (cursor:cursor-value cursor) + "expected PACKAGE or (PACKAGE as NICK)"))))) (defun parse-import-from (package cursor) "Parse an IMPORT-FROM clause: a package designator followed by uninterned symbols." @@ -585,8 +585,8 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (defun parse-import (package cursor) (when (cursor:empty-p cursor) - (cursor:syntax-error cursor "empty IMPORT form" :end t)) - (cursor:do-every cursor (alexandria:curry 'parse-import-statement package))) + (cursor:error cursor ':after-last "empty IMPORT form")) + (cursor:each cursor (alexandria:curry 'parse-import-statement package))) (defun parse-export (package cursor) (setf (toplevel-package-export package) @@ -609,30 +609,35 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo (defun parse-package-clause (package cursor) "Parse a package clause form CURSOR and add it to PACKAGE." - (unless (consp (cursor:peek cursor)) - (cursor:syntax-error cursor "malformed package clause")) - (let ((clause-name-location (cursor:cursor-location cursor)) - (parser (package-clause-parser (cursor:next-symbol cursor)))) - (when (null parser) + (unless (cst:consp (cursor:cursor-pointer cursor)) + (cursor:error cursor ':form "malformed package clause")) + (let* ((clause-name (cursor:next cursor :unwrap nil)) + (clause-name-location (source:make-location (cursor:cursor-source cursor) + (cst:source clause-name)))) + (unless (symbolp (cst:raw clause-name)) (parse-error (cursor:cursor-message cursor) - (source:note (source:location cursor) - "Unknown package clause") - (source:help clause-name-location - #'identity - "Must be one of ~{~a~^, ~}" - (mapcar #'car *package-clauses*)))) - (funcall parser package cursor))) + (source:note clause-name-location + "not a symbol"))) + (let ((parser (package-clause-parser (cst:raw clause-name)))) + (when (null parser) + (parse-error (cursor:cursor-message cursor) + (source:note clause-name-location + "Unknown package clause") + (source:help clause-name-location + #'identity + "Must be one of ~{~a~^, ~}" + (mapcar #'car *package-clauses*)))) + (funcall parser package cursor)))) + (defun parse-package (cursor) "Parse a coalton package declaration." - (cursor:next-symbol cursor - :require "PACKAGE" - :message "package declarations must start with `package`" - :missing "missing `package`") + (cursor:discard-symbol cursor 'package + "package declarations must start with `package`") (let* ((package-name (cursor:next-symbol cursor - :missing "missing package name" - :message "package name must be a symbol")) + "missing package name" + "package name must be a symbol")) (package-doc (unless (cursor:empty-p cursor) (cursor:next cursor :pred #'stringp))) @@ -641,7 +646,7 @@ If MODE is :macro, a package form is forbidden, and an explicit check is made fo :docstring package-doc :location (form-location (cursor:cursor-source cursor) (cursor:cursor-value cursor))))) - (cursor:do-every cursor (alexandria:curry 'parse-package-clause package)) + (cursor:each cursor (alexandria:curry #'parse-package-clause package)) package)) ;; Empty package for reading (package) forms @@ -732,14 +737,14 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid lisp-toplevel form" (note source (cst:first (cst:rest form)) "saw 'def' form: in lisp-toplevel, code must be preceded by an empty options list") - (note source form - "when parsing lisp-toplevel"))) + (secondary-note source form + "when parsing lisp-toplevel"))) (t (parse-error "Invalid lisp-toplevel form" (note source (cst:first (cst:rest form)) "lisp-toplevel must be followed by an empty options list") - (note source form - "when parsing lisp-toplevel")))))) + (secondary-note source form + "when parsing lisp-toplevel")))))) (loop :for form :in (cst:raw (cst:rest (cst:rest form))) :when (eval-toplevel-p form) @@ -791,18 +796,18 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid target for repr attribute" (note source attribute-form "repr must be attached to a define-type") - (source:note (toplevel-define-name define) - "when parsing define"))) + (source:secondary-note (toplevel-define-name define) + "when parsing define"))) (attribute-monomorphize (when monomorphize (parse-error "Duplicate monomorphize attribute" (note source attribute-form "monomorphize attribute here") - (note source monomorphize-form - "previous attribute here") - (source:note (toplevel-define-name define) - "when parsing define"))) + (secondary-note source monomorphize-form + "previous attribute here") + (source:secondary-note (toplevel-define-name define) + "when parsing define"))) (setf monomorphize attribute) (setf monomorphize-form attribute-form)))) @@ -824,16 +829,16 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid target for repr attribute" (note source attribute-form "repr must be attached to a define-type") - (note source form "when parsing declare"))) + (secondary-note source form "when parsing declare"))) (attribute-monomorphize (when monomorphize (parse-error "Duplicate monomorphize attribute" (note source attribute-form "monomorphize attribute here") - (note source monomorphize-form - "previous attribute here") - (note source form "when parsing declare"))) + (secondary-note source monomorphize-form + "previous attribute here") + (secondary-note source form "when parsing declare"))) (setf monomorphize attribute) (setf monomorphize-form attribute-form)))) @@ -856,9 +861,9 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Duplicate repr attribute" (note source attribute-form "repr attribute here") - (note source repr-form - "previous attribute here") - (source:note type "when parsing define-type"))) + (secondary-note source repr-form + "previous attribute here") + (source:secondary-note type "when parsing define-type"))) (setf repr attribute) (setf repr-form attribute-form)) @@ -867,7 +872,7 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid target for monomorphize attribute" (note source attribute-form "monomorphize must be attached to a define or declare form") - (source:note type "when parsing define-type"))))) + (source:secondary-note type "when parsing define-type"))))) (setf (fill-pointer attributes) 0) (setf (toplevel-define-type-repr type) repr) @@ -886,7 +891,7 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (when repr (parse-error "Duplicate repr attribute" (note source attribute-form "repr attribute here") - (note source repr-form "previous attribute here") + (secondary-note source repr-form "previous attribute here") (note source (toplevel-define-struct-head-location struct) "when parsing define-struct"))) @@ -894,8 +899,8 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid repr attribute" (note source attribute-form "structs can only be repr transparent") - (note source (toplevel-define-struct-head-location struct) - "when parsing define-struct"))) + (secondary-note source (toplevel-define-struct-head-location struct) + "when parsing define-struct"))) (setf repr attribute) (setf repr-form attribute-form)) @@ -904,8 +909,8 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid target for monomorphize attribute" (note source attribute-form "monomorphize must be attached to a define or declare form") - (note source (toplevel-define-struct-name struct) - "when parsing define-type"))))) + (secondary-note source (toplevel-define-struct-name struct) + "when parsing define-type"))))) (setf (fill-pointer attributes) 0) (setf (toplevel-define-struct-repr struct) repr) @@ -919,8 +924,8 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid attribute for define-class" (note source (cdr (aref attributes 0)) "define-class cannot have attributes") - (source:note (toplevel-define-class-head-location class) - "while parsing define-class"))) + (source:secondary-note (toplevel-define-class-head-location class) + "while parsing define-class"))) (push class (program-classes program)) t)) @@ -932,8 +937,8 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid attribute for define-instance" (note source (cdr (aref attributes 0)) "define-instance cannot have attributes") - (source:note (toplevel-define-instance-head-location instance) - "while parsing define-instance"))) + (source:secondary-note (toplevel-define-instance-head-location instance) + "while parsing define-instance"))) (push instance (program-instances program)) t)) @@ -947,8 +952,8 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid lisp-toplevel form" (note source (cdr (aref attributes 0)) "lisp-toplevel cannot have attributes") - (note source form - "when parsing lisp-toplevel"))) + (secondary-note source form + "when parsing lisp-toplevel"))) (parse-lisp-toplevel-form form program source) t) @@ -957,8 +962,9 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (unless (zerop (length attributes)) (source:error "Invalid attribute for specialize" - (note source (cdr (aref attributes 0)) "specialize cannot have attributes") - (note source form "when parsing specialize"))) + (note source (cdr (aref attributes 0)) + "specialize cannot have attributes") + (secondary-note source form "when parsing specialize"))) (push spec (program-specializations program)) t)) @@ -968,8 +974,8 @@ If the outermost form matches (eval-when (compile-toplevel) ..), evaluate the en (parse-error "Invalid attribute for progn" (note source (cdr (aref attributes 0)) "progn cannot have attributes") - (note source form - "when parsing progn"))) + (secondary-note source form + "when parsing progn"))) (loop :for inner-form := (cst:rest form) :then (cst:rest inner-form) :while (not (cst:null inner-form)) :do @@ -982,8 +988,8 @@ consume all attributes"))) (parse-error "Trailing attributes in progn" (note source (cdr (aref attributes 0)) "progn cannot have trailing attributes") - (note source form - "when parsing progn"))) + (secondary-note source form + "when parsing progn"))) t) (t @@ -991,11 +997,8 @@ consume all attributes"))) ((and (cst:atom (cst:first form)) (symbolp (cst:raw (cst:first form))) (macro-function (cst:raw (cst:first form)))) - (let ((se:*source-error-context* - (adjoin (se:make-source-error-context - :message "Error occurs within macro context. Source locations may be imprecise") - se:*source-error-context* - :test #'equalp))) + (source:with-context + (:macro "Error occurs within macro context. Source locations may be imprecise") (parse-toplevel-form (expand-macro form source) program attributes source))) ((parse-error "Invalid toplevel form" @@ -1113,7 +1116,8 @@ consume all attributes"))) "expected symbol"))) (setf name (make-identifier-src :name (cst:raw (cst:first (cst:second form))) - :location (form-location source (cst:first (cst:second form))))) + :location (form-location source + (cst:first (cst:second form))))) ;; (define-type (T) ...) (when (cst:atom (cst:rest (cst:second form))) @@ -1137,26 +1141,23 @@ consume all attributes"))) (when (and docstring (cst:consp (cst:nthrest 3 form)) (stringp (cst:raw (cst:fourth form)))) - (error 'parse-error - :err (se:source-error - :span (cst:source (cst:fourth form)) - :source source - :message "Malformed type definition" - :primary-note "only one docstring allowed." - :help-notes - (list - (se:make-source-error-help - :span (cst:source (cst:fourth form)) - :replacement - (lambda (existing) - (subseq existing 1 (1- (length existing)))) - :message "remove additional docstring"))))) + (parse-error "Malformed type definition" + (note source + (cst:source (cst:fourth form)) + "only one docstring allowed.") + (help source + (cst:source (cst:fourth form)) + (lambda (existing) + (subseq existing 1 (1- (length existing)))) + "remove additional docstring"))) (make-toplevel-define-type :name name :vars (reverse variables) :docstring docstring - :ctors (loop :for constructors_ := (cst:nthrest (if docstring 3 2) form) :then (cst:rest constructors_) + :ctors (loop :for constructors_ + := (cst:nthrest (if docstring 3 2) form) + :then (cst:rest constructors_) :with ctors := nil :while (cst:consp constructors_) @@ -1166,12 +1167,10 @@ consume all attributes"))) (not (cst:null (cst:rest constructors_))) (cst:atom (cst:second constructors_)) (stringp (cst:raw (cst:second constructors_)))) - :do (error 'parse-error - :err (se:source-error - :span (cst:source (cst:second constructors_)) - :source source - :message "Malformed type definition" - :primary-note "only one docstring allowed per constructor")) + :do (parse-error "Malformed type definition" + (note source + (cst:second constructors_) + "only one docstring allowed per constructor")) ;; collect constructors with docstrings if they follow :do (let ((ctor-docstring (if (and (not (cst:null (cst:rest constructors_))) @@ -1371,7 +1370,8 @@ consume all attributes"))) ;; ((C1 ...) (C2 ...) ... => C3 ...) (setf predicates (loop :for pred :in left - :collect (parse-predicate (cst:listify pred) (form-location source pred)))))) + :collect (parse-predicate (cst:listify pred) + (form-location source pred)))))) (when (and (cst:consp (cst:rest (cst:rest form))) (cst:atom (cst:third form)) @@ -1379,7 +1379,9 @@ consume all attributes"))) (setf docstring (cst:raw (cst:third form)))) (setf methods - (loop :for methods := (cst:nthrest (if docstring 3 2) form) :then (cst:rest methods) + (loop :for methods + := (cst:nthrest (if docstring 3 2) form) + :then (cst:rest methods) :while (cst:consp methods) :collect (parse-method (cst:first methods) form source))) @@ -1409,7 +1411,7 @@ consume all attributes"))) ;; (define-instance) (unless (cst:consp (cst:rest form)) (parse-error "Malformed instance definition" - (note-end source form "expected an instance head"))) + (note-end source (cst:first form) "expected an instance head"))) ;; (define-instance 5) (unless (cst:consp (cst:second form)) @@ -1476,12 +1478,14 @@ consume all attributes"))) (if (cst:atom (first unparsed-context)) (setf context (list (parse-predicate unparsed-context - (source:make-location source - (util:cst-source-range unparsed-context))))) + (source:make-location + source + (util:cst-source-range unparsed-context))))) (setf context (loop :for unparsed :in unparsed-context - :collect (parse-predicate (cst:listify unparsed) (form-location source unparsed)))))) + :collect (parse-predicate (cst:listify unparsed) + (form-location source unparsed)))))) (when (and (cst:consp (cst:rest (cst:rest form))) (cst:atom (cst:third form)) @@ -1494,10 +1498,13 @@ consume all attributes"))) (source:make-location source (util:cst-source-range unparsed-predicate))) :docstring docstring - :methods (loop :for methods := (cst:nthrest (if docstring 3 2) form) :then (cst:rest methods) + :methods (loop :for methods + := (cst:nthrest (if docstring 3 2) form) + :then (cst:rest methods) :while (cst:consp methods) :for method := (cst:first methods) - :collect (parse-instance-method-definition method (cst:second form) source)) + :collect (parse-instance-method-definition method + (cst:second form) source)) :location (form-location source form) :head-location (form-location source (cst:second form)) :compiler-generated nil)))) @@ -1540,68 +1547,64 @@ consume all attributes"))) (declare (type cst:cst method-form) (values method-definition)) - ;; m or (m) - (unless (and (cst:consp method-form) - (cst:consp (cst:rest method-form))) - (parse-error "Malformed method definition" - (note source method-form "missing method type") - (note source (cst:second form) "in this class definition"))) - - ;; (m d t ...) - (unless (or (cst:null (cst:rest (cst:rest method-form))) - (cst:null (cst:rest (cst:rest (cst:rest method-form))))) - (parse-error "Malformed method definition" - (note source (cst:first (cst:rest (cst:rest (cst:rest method-form)))) - "unexpected trailing form") - (note source (cst:second form) - "in this class definition"))) - - ;; (0.5 t ...) - (unless (and (cst:atom (cst:first method-form)) - (identifierp (cst:raw (cst:first method-form)))) - (parse-error "Malformed method definition" - (note source (cst:first method-form) - "expected symbol") - (note source (cst:second form) - "in this class definition"))) - - ;; (m "docstring") - (when (and (cst:atom (cst:second method-form)) - (stringp (cst:raw (cst:second method-form))) - (cst:null (cst:rest (cst:rest method-form)))) - (parse-error "Malformed method definition" - (note source (cst:second method-form) - "missing method type") - (note source (cst:second form) - "in this class definition"))) - - (let (docstring) - (when (and (cst:atom (cst:second method-form)) - (stringp (cst:raw (cst:second method-form)))) - (setf docstring (cst:raw (cst:second method-form)))) + (let ((class-note (secondary-note source (cst:second form) + "in this class definition"))) + ;; m or (m) + (unless (and (cst:consp method-form) + (cst:consp (cst:rest method-form))) + (parse-error "Malformed method definition" + (note source method-form "missing method type") + class-note)) - ;; either list of length 2 or list of length 3 with docstring + ;; (m d t ...) (unless (or (cst:null (cst:rest (cst:rest method-form))) - (and (cst:atom (cst:second method-form)) - (stringp (cst:raw (cst:second method-form))))) + (cst:null (cst:rest (cst:rest (cst:rest method-form))))) (parse-error "Malformed method definition" - (note source (if docstring - (cst:fourth method-form) - (cst:third method-form)) + (note source (cst:first (cst:rest (cst:rest (cst:rest method-form)))) "unexpected trailing form") - (note source (cst:second form) - "in this class definition"))) + class-note)) - (make-method-definition - :name (make-identifier-src - :name (node-variable-name (parse-variable (cst:first method-form) source)) - :location (form-location source (cst:first method-form))) - :docstring docstring - :type (parse-qualified-type (if docstring - (cst:third method-form) - (cst:second method-form)) - source) - :location (form-location source method-form)))) + ;; (0.5 t ...) + (unless (and (cst:atom (cst:first method-form)) + (identifierp (cst:raw (cst:first method-form)))) + (parse-error "Malformed method definition" + (note source (cst:first method-form) "expected symbol") + class-note)) + + ;; (m "docstring") + (when (and (cst:atom (cst:second method-form)) + (stringp (cst:raw (cst:second method-form))) + (cst:null (cst:rest (cst:rest method-form)))) + (parse-error "Malformed method definition" + (note source (cst:second method-form) "missing method type") + class-note)) + + (let (docstring) + (when (and (cst:atom (cst:second method-form)) + (stringp (cst:raw (cst:second method-form)))) + (setf docstring (cst:raw (cst:second method-form)))) + + ;; either list of length 2 or list of length 3 with docstring + (unless (or (cst:null (cst:rest (cst:rest method-form))) + (and (cst:atom (cst:second method-form)) + (stringp (cst:raw (cst:second method-form))))) + (parse-error "Malformed method definition" + (note source (if docstring + (cst:fourth method-form) + (cst:third method-form)) + "unexpected trailing form") + class-note)) + + (make-method-definition + :name (make-identifier-src + :name (node-variable-name (parse-variable (cst:first method-form) source)) + :location (form-location source (cst:first method-form))) + :docstring docstring + :type (parse-qualified-type (if docstring + (cst:third method-form) + (cst:second method-form)) + source) + :location (form-location source method-form))))) (defun parse-type-variable (form source) (declare (type cst:cst form) @@ -1641,12 +1644,14 @@ consume all attributes"))) (unless (cst:atom unparsed-name) (parse-error "Malformed constructor" (note source unparsed-name "expected symbol") - (note source (cst:second enclosing-form) "in this type definition"))) + (secondary-note source (cst:second enclosing-form) + "in this type definition"))) (unless (identifierp (cst:raw unparsed-name)) (parse-error "Malformed constructor" (note source unparsed-name "expected symbol") - (note source (cst:second enclosing-form) "in this type definition"))) + (secondary-note source (cst:second enclosing-form) + "in this type definition"))) (make-constructor :name (make-identifier-src @@ -1713,9 +1718,9 @@ consume all attributes"))) (let (docstring unparsed-body) - ;; (define y 2) (when (cst:atom (cst:rest form)) - (return-from parse-definition-body (values nil (parse-body form enclosing-form source)))) + (return-from parse-definition-body + (values nil (parse-body form enclosing-form source)))) (if (and (cst:atom (cst:first form)) (stringp (cst:raw (cst:first form)))) @@ -1732,7 +1737,7 @@ consume all attributes"))) (type cst:cst parent-form) (values instance-method-definition)) - (let ((context-note (note source parent-form "when parsing instance"))) + (let ((context-note (secondary-note source parent-form "when parsing instance"))) (unless (cst:consp form) (parse-error "Malformed method definition" @@ -1765,39 +1770,26 @@ consume all attributes"))) :location (form-location source form))))) (defun parse-fundep (form source) + "Parse a functional dependency in FORM, consisting of two lists of one or more type variables separated by `->`: + +:a ... :n -> :a ... :n" (declare (type cst:cst form) (values fundep)) - - (unless (cst:consp form) - (parse-error "Malformed functional dependency" - (note source form "expected a list"))) - - (unless (cst:proper-list-p form) - (parse-error "Malformed functional dependency" - (note source form "unexpected dotted list"))) - - (multiple-value-bind (left right) - (util:take-until - (lambda (cst) - (and (cst:atom cst) - (eq (cst:raw cst) 'coalton:->))) - (cst:listify form)) - - (unless left - (parse-error "Malformed functional dependency" - (note source form "expected one or more type variables"))) - - (unless (rest right) - (parse-error "Malformed functional dependency" - (note-end source form "expected one or more type variables"))) - - (make-fundep - :left (loop :for var :in left - :collect (parse-type-variable var source)) - :right (loop :for var :in (cdr right) - :collect (parse-type-variable var source)) - :location (form-location source form)))) - + (let ((cursor (cursor:make-cursor form source "Malformed functional dependency"))) + (labels ((parse-var (cst) + (parse-type-variable cst source)) + (require-vars (vars) + (when (endp vars) + (cursor:error cursor ':after-last "expected one or more type variables")) + vars)) + (let ((left (require-vars (cursor:collect cursor :key #'parse-var + :test (lambda (value) + (not (eq value 'coalton:->))))))) + (cursor:next cursor) ; drop the arrow + (let ((right (require-vars (cursor:collect cursor :key #'parse-var)))) + (make-fundep :left left + :right right + :location (form-location source form))))))) (defun parse-monomorphize (form source) (declare (type cst:cst form) @@ -1828,7 +1820,7 @@ consume all attributes"))) (progn ;; :native reprs must have an argument (unless (cst:consp (cst:rest (cst:rest form))) (parse-error "Malformed repr :native attribute" - (note-end source form "expected a lisp type"))) + (note-end source (cst:second form) "expected a lisp type"))) (when (cst:consp (cst:rest (cst:rest (cst:rest form)))) (parse-error "Malformed repr :native attribute" @@ -1864,40 +1856,22 @@ consume all attributes"))) (declare (type cst:cst form) (values struct-field)) - ;; 5 - (unless (cst:consp form) - (parse-error "Malformed struct field" - (note source form "unexpected form"))) - - ;; (5 ...) - (unless (and (cst:atom (cst:first form)) - (symbolp (cst:raw (cst:first form)))) - (parse-error "Malformed struct field" - (note-end source form "invalid field name (must be a symbol)"))) - - ;; (name) - (unless (cst:consp (cst:rest form)) - (parse-error "Malformed struct field" - (note source form "expected field type"))) - - (multiple-value-bind (docstring rest-field) - (if (stringp (cst:raw (cst:second form))) - (values (and (cst:raw (cst:first (cst:rest form)))) (cst:rest (cst:rest form))) - (values nil (cst:rest form))) - - ;; (name docstring) - (when (cst:null rest-field) - (parse-error "Malformed struct field" - (note-end source form "expected field type"))) - - ;; (name ty ...) or (name "docstring" ty ...) - (unless (cst:null (cst:rest rest-field)) - (parse-error "Malformed struct field" - (note-end source form "unexpected trailing form"))) - - (make-struct-field - :name (symbol-name (cst:raw (cst:first form))) - :type (parse-type (cst:first rest-field) - source) - :docstring docstring - :location (form-location source form)))) + (let ((cursor (cursor:make-cursor form source "Malformed struct field"))) + (when (cursor:atom-p cursor) + (cursor:error cursor ':form "unexpected form")) + (let ((name (cursor:next-symbol cursor + "missing field name" + "invalid field name (must be a symbol)")) + (docstring nil)) + (when (stringp (cursor:peek cursor)) + (setf docstring (cursor:next cursor))) + (unless (cursor:peek cursor) + (cursor:error cursor ':after-last "expected field type")) + (let ((type (cursor:next cursor :unwrap nil))) + (when (cursor:peek cursor :unwrap nil) + (cursor:error cursor ':next "unexpected trailing form")) + + (make-struct-field :name (symbol-name name) + :type (parse-type type source) + :docstring docstring + :location (form-location source form)))))) diff --git a/src/reader.lisp b/src/reader.lisp index 226ff659..25854c66 100644 --- a/src/reader.lisp +++ b/src/reader.lisp @@ -2,10 +2,10 @@ (:use #:cl) (:local-nicknames - (#:se #:source-error) (#:cst #:concrete-syntax-tree) (#:codegen #:coalton-impl/codegen) (#:settings #:coalton-impl/settings) + (#:source #:coalton-impl/source) (#:util #:coalton-impl/util) (#:parser #:coalton-impl/parser) (#:tc #:coalton-impl/typechecker) @@ -138,7 +138,7 @@ It ensures the presence of source metadata for STREAM and then calls MAYBE-READ- (write-char #\( out) (alexandria:copy-stream stream out)) :name "repl"))) - (with-open-stream (stream (source-error:source-stream *source*)) + (with-open-stream (stream (source:source-stream *source*)) (read-char stream) (maybe-read-coalton stream *source*)))))) diff --git a/src/source.lisp b/src/source.lisp index 80ae0e84..c9c4f6b8 100644 --- a/src/source.lisp +++ b/src/source.lisp @@ -6,30 +6,33 @@ (:shadow #:error #:warn) - (:local-nicknames - (#:se #:source-error)) (:export #:char-position-stream + #:docstring + #:end-location #:error - #:warn #:help - #:note - #:primary-note - #:message - #:make-source-error - #:make-source-file - #:make-source-string #:location - #:end-location - #:make-location #:location-source #:location-span #:location< + #:make-location + #:make-source-error + #:make-source-file + #:make-source-string + #:message + #:note + #:secondary-note + #:source-available-p + #:source-error + #:source-name + #:source-stream + #:source-warning #:span - #:span-start #:span-end - #:docstring - #:source-error)) + #:span-start + #:warn + #:with-context)) (in-package #:coalton-impl/source) @@ -68,12 +71,21 @@ (read-char (inner-stream stream))) (setf (character-position stream) position-spec)) -;; source input +;;; Docstrings -(defgeneric source< (a b) - (:method (a b) - nil) - (:documentation "Compare two source locations, returning T if the string name of A is lexicographically earlier than that of B.")) +(defgeneric docstring (object) + (:documentation "The docstring accompanying a Coalton object's definition.")) + +;;; Sources + +(defgeneric source-stream (source) + (:documentation "Open and return a stream from which source text may be read. The caller is responsible for closing the stream, and the stream's initial position may be greater than zero.")) + +(defgeneric source-available-p (source) + (:documentation "Return T if a stream containing SOURCE's source text can be opened.")) + +(defgeneric source-name (source) + (:documentation "The name of an error's source, suitable for reporting in errors. If the source is a file, SOURCE-NAME will be that file's absolute path.")) (defclass source () ((name :initarg :name @@ -83,7 +95,7 @@ In the case of source that is copied to a different location during compilation (e.g., by emacs+slime), original file name preserves the original location.")) -(defmethod source< ((a source) (b source)) +(defun source< (a b) (and (original-name a) (original-name b) (string< (original-name a) @@ -124,14 +136,14 @@ OFFSET indicates starting character offset within the file." :name (ensure-namestring name) :offset offset)) -(defmethod source-error:source-available-p ((self source-file)) +(defmethod source-available-p ((self source-file)) (not (null (input-name self)))) -(defmethod source-error:source-name ((self source-file)) +(defmethod source-name ((self source-file)) (or (original-name self) (input-name self))) -(defmethod source-error:source-stream ((self source-file)) +(defmethod source-stream ((self source-file)) (let* ((fd-stream (open (input-name self) :direction ':input :element-type 'character @@ -162,21 +174,20 @@ OFFSET indicates starting character offset within the file." :string string :name (ensure-namestring name))) -(defmethod source-error:source-available-p ((self source-string)) +(defmethod source-available-p ((self source-string)) (not (null (source-string self)))) -(defmethod source-error:source-stream ((self source-string)) +(defmethod source-name ((self source-string)) + (or (original-name self) "")) + +(defmethod source-stream ((self source-string)) (make-string-input-stream (source-string self))) -(defmethod source-error:source-name ((self source-string)) - (or (original-name self) "")) +;;; Spans and locations (defgeneric location (object) (:documentation "The source location of a Coalton object's definition.")) -(defgeneric docstring (object) - (:documentation "The docstring accompanying a Coalton object's definition.")) - (deftype span () "A pair of offsets that indicates a range of characters in a source file." '(cons fixnum fixnum)) @@ -208,16 +219,12 @@ OFFSET indicates starting character offset within the file." (= (span-start span) (span-end span))) -(defstruct (location - (:constructor %make-location)) +(defstruct (location (:constructor %make-location)) (source nil :read-only t) (span nil :type span :read-only t)) -(defgeneric location (object) - (:documentation "The location of a Coalton object's source definition.")) - (defun end-location (location) "Return a new location that points at a zero-length span immediately past tht end of LOCATION." (make-location (location-source location) @@ -241,6 +248,8 @@ If locations appear in different sources, compare the sources by name." (%make-location :source source :span span)) +;;; Notes + (defgeneric message (object) (:documentation "The primary message associated with an object.")) @@ -260,10 +269,11 @@ If locations appear in different sources, compare the sources by name." (defmethod print-object ((self note) stream) (if *print-readably* (call-next-method) - (format stream "~(~a~) note: ~a: ~a" - (note-type self) - (location self) - (message self)))) + (print-unreadable-object (self stream :type t :identity t) + (format stream "~(~a~) note: ~a: ~a" + (note-type self) + (location self) + (message self))))) (defun ensure-location (locatable) (typecase locatable @@ -275,15 +285,16 @@ If locations appear in different sources, compare the sources by name." (declare (type string format-string)) (make-instance 'note :location (ensure-location location) - :message (apply #'format nil format-string format-args))) + :message (apply #'format nil format-string format-args) + :type ':primary)) -(defun primary-note (location format-string &rest format-args) +(defun secondary-note (location format-string &rest format-args) "Return a note that describes a primary source LOCATION." (declare (type string format-string)) (make-instance 'note :location (ensure-location location) :message (apply #'format nil format-string format-args) - :type ':primary)) + :type ':secondary)) (defun help (location replace format-string &rest format-args) "Return a help note related to a source LOCATION. @@ -297,46 +308,445 @@ REPLACE is a 1-argument function that accepts and returns a string to suggest an :replace replace :type ':help)) -;;; The following functions up to SOURCE-ERROR are for interfacing -;;; with the SOURCE-ERROR package." - -(defun help-note-p (note) - "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 (location-span (location note)) - :type (note-type note) - :message (message note))) - -(defun note->help-note (note) - "Convert NOTE to a source error help note." - (se:make-source-error-help :span (location-span (location note)) - :replacement (replace-function note) - :message (message note))) - -(defun make-source-error (type message notes) - "Build a SOURCE-ERROR:SOURCE-ERROR structure by destructuring the first note in NOTES, and translating remaining notes to SOURCE-ERROR versions." - (destructuring-bind (primary &rest secondary) notes - (let ((primary-span (location-span (location primary)))) - (se:source-error :type type - :span primary-span - :source (location-source (location primary)) - :highlight (if (span-empty-p primary-span) :end :all) - :message message - :primary-note (message primary) - :notes (mapcar #'note->source-note - (remove-if #'help-note-p secondary)) - :help-notes (mapcar #'note->help-note - (remove-if-not #'help-note-p secondary)))))) +(defvar *context* nil) + +(defmacro with-context ((key message) &body body) + `(let ((*context* (cons (cons ,key ,message) *context*))) + ,@body)) + +(defgeneric context (object)) + +(defgeneric severity (object)) + +;;; Printer +;;; +;;; `report-source-condition`, at the bottom, is a workhorse function that +;;; takes a source condition, resolves source-relative locations +;;; to the input source, and prints annotated source code. +;;; +;;; `printer-state` maintains state during printing: current line, +;;; note depth, etc. + +(defclass printer-state () + ((source-stream :initarg :source-stream + :reader source-stream) + (notes :initarg :notes) + (help :initarg :help) + (context :initarg :context) + (line-offsets :reader line-offsets) + (offset-positions :initform (make-hash-table)) + (line-number-width) + (current-line) + (last-line) + + ;; Keep track of the current depth of multiline notes in order to + ;; pad the left with the correct number of columns. + + (note-stack :accessor note-stack + :initform nil) + (note-max-depth :initform 0))) + +(defun first-line-number (notes offset-positions) + (unless (null notes) + (span-start (gethash (start-offset (car notes)) offset-positions)))) + +(defun last-line-number (notes offset-positions) + (let ((last-offset (apply #'max (mapcar #'end-offset notes)))) + (span-start (gethash last-offset offset-positions)))) + +(defmethod initialize-instance :after ((printer-state printer-state) &rest initargs) + (declare (ignore initargs)) + (with-slots (source-stream + line-offsets + offset-positions + note-max-depth + current-line + last-line + line-number-width + notes) + printer-state + (let ((char-offsets (char-offsets printer-state)) + (offsets (find-line-offsets source-stream))) + (setf line-offsets (coerce offsets 'vector)) + (loop :for (char-offset line column) :in (find-column-offsets offsets char-offsets) + :do (setf (gethash char-offset offset-positions) + (cons line column))) + (setf current-line (1- (first-line-number notes offset-positions)) + last-line (last-line-number notes offset-positions) + line-number-width (1+ (floor (log last-line 10))) + note-max-depth (max-depth (remove-if-not (lambda (note) + (multiline-p printer-state note)) + notes)))))) + +(defun start-offset (note) + (span-start (location-span (location note)))) + +(defun start-position (printer-state note) + (with-slots (offset-positions) printer-state + (gethash (start-offset note) offset-positions))) + +(defun end-offset (note) + (cdr (location-span (location note)))) + +(defun end-position (printer-state note) + (with-slots (offset-positions) printer-state + (gethash (end-offset note) offset-positions))) + +(defun location-lines (printer-state note) + "Return the start and end lines of NOTE" + (let ((start-line (car (start-position printer-state note))) + (end-line (car (end-position printer-state note)))) + (values start-line end-line))) + +(defun multiline-p (printer-state note) + "Return the start and end lines of NOTE" + (< (car (start-position printer-state note)) + (car (end-position printer-state note)))) + +(defun location-positions (printer-state note) + "Return the start and end positions of NOTE" + (with-slots (offset-positions) printer-state ; FIXME purge with-slots + (destructuring-bind (start-line . start-column) + (gethash (start-offset note) offset-positions) + (destructuring-bind (end-line . end-column) + (gethash (end-offset note) offset-positions) + (values start-line start-column end-line end-column))))) + +;; Mapping between character offsets and line and column positions. +;; +;; First line (zero indexed) = offset 0, etc. + +(defun find-line-offsets (stream) + "Compute the offsets of lines in STREAM." + (file-position stream 0) + (loop :with index := 0 + :for char := (read-char stream nil nil) + :unless char + :return (cons 0 offsets) + :when (char= char #\Newline) + :collect (1+ index) :into offsets + :do (incf index))) + +(defun find-column-offsets (line-offsets offsets) + "Given the offsets of newlines in a stream, compute the line and +column numbers for a sequence of absolute stream offsets." + (loop :with line := 0 + :with position := 0 + :while offsets + :when (or (null line-offsets) + (< (car offsets) + (car line-offsets))) + :collect (list (car offsets) line (- (car offsets) position)) + :and :do (pop offsets) + :else + :do (setf position (car line-offsets) + line (1+ line) + line-offsets (cdr line-offsets)))) + +(defun line-contents (printer-state line-number) + (with-slots (line-offsets source-stream) printer-state + (let ((offset (if (= 1 line-number) + 0 + (aref line-offsets (1- line-number))))) + (file-position source-stream offset) + (read-line source-stream nil "")))) + +(defun positioned-annotations (printer-state) + (with-slots (notes help) printer-state + (concatenate 'list notes help))) + +(defun char-offsets (printer-state) + (sort (remove-duplicates + (mapcan (lambda (note) + (list (start-offset note) (end-offset note))) + (positioned-annotations printer-state))) + #'<)) + +(defun start-line (printer-state location) + (with-slots (offset-positions) printer-state + (car (gethash (start-offset location) offset-positions)))) + +(defun start-column (printer-state location) + (with-slots (offset-positions) printer-state + (cdr (gethash (start-offset location) offset-positions)))) + +(defun end-line (printer-state location) + (with-slots (offset-positions) printer-state + (car (gethash (end-offset location) offset-positions)))) + +(defun end-column (printer-state location) + (with-slots (offset-positions) printer-state + (cdr (gethash (end-offset location) offset-positions)))) + +(defun location-point< (a b) + (destructuring-bind (offset-a . type-a) a + (destructuring-bind (offset-b . type-b) b + (if (= offset-a offset-b) + (and (eql type-a :start) + (eql type-b :end)) + (< offset-a offset-b))))) + +(defun location-points (location) + (list (cons (start-offset location) :start) + (cons (end-offset location) :end))) + +(defun max-depth (notes) + (let ((max-depth 0) + (depth 0)) + (dolist (op (mapcar #'cdr (sort (mapcan #'location-points notes) #'location-point<)) max-depth) + (cond ((eql op :start) + (incf depth) + (when (< max-depth depth) + (setf max-depth depth))) + ((eql op :end) + (decf depth)))) + max-depth)) + +(defun offset-position (printer-state location) + (let ((location (etypecase location + (cons (car location)) + (integer location)))) + (gethash location (slot-value printer-state 'offset-positions) (cons 1 0)))) + +(defun note-help-p (note) + (eq (note-type note) ':help)) + +(defun note-primary-p (note) + (eq (note-type note) ':primary)) + +(defun note-highlight-char (note) + (if (note-primary-p note) + #\^ + #\-)) + +(defun write-nchar (char n stream) + (dotimes (n n) + (write-char char stream))) + +;;; Printer + +(defun %primary-note (condition) + (first (notes condition))) + +(defun print-condition-location (stream printer-state condition) + (let* ((note (%primary-note condition)) + (source (location-source (location note)))) + (destructuring-bind (line . column) + (offset-position printer-state (start-offset note)) + (format stream "~(~A~): ~A~% --> ~A:~D:~D~%" + (severity condition) + (message condition) + (source-name source) + line + column)))) + +(defun print-line-prefix (stream printer-state &key (line-number nil)) + (with-slots (line-number-width) printer-state + (cond (line-number + (format stream " ~va |" line-number-width line-number)) + (t + (write-nchar #\Space (+ 2 line-number-width) stream) + (write-char #\| stream))))) + +(defun print-line-number (stream printer-state line-number show-line-number) + (with-slots (line-number-width note-stack) printer-state + (print-line-prefix stream printer-state :line-number (and show-line-number line-number)) + (format stream + " ~{~:[ ~;|~]~}" + (mapcar + (lambda (note) + (>= (end-line printer-state note) + line-number)) + note-stack)))) + +(defun print-line-contents (stream printer-state line-number) + (print-line-number stream printer-state line-number t) + (with-slots (note-stack note-max-depth) printer-state + (format stream "~v@{ ~}~A~%" + (1+ (- note-max-depth (length note-stack))) + (line-contents printer-state line-number)))) + +(defun print-single-line-note (stream printer-state note) + (multiple-value-bind (start-line start-column end-line end-column) + (location-positions printer-state note) + (declare (ignore end-line)) + (print-line-number stream printer-state start-line nil) + (with-slots (note-max-depth note-stack) printer-state + (write-nchar #\Space + (+ 1 + start-column + (- note-max-depth (length note-stack))) + stream) + (format stream "~v{~C~:*~} ~A~%" + (max 1 (- end-column start-column)) + (list (note-highlight-char note)) + (message note))))) + +(defun print-note-start (stream printer-state note) + (destructuring-bind (start-line . start-column) + (start-position printer-state note) + (print-line-number stream printer-state start-line nil) + (with-slots (note-max-depth note-stack) printer-state + (write-char #\Space stream) + (write-nchar #\_ (+ 1 start-column (- note-max-depth (length note-stack) 1)) stream) + (write-char (note-highlight-char note) stream) + (terpri stream)))) + +(defun print-note-end (stream printer-state note) + (let ((start-line (start-line printer-state note)) + (end-column (end-column printer-state note))) + (print-line-number stream printer-state start-line nil) + (with-slots (note-max-depth note-stack) printer-state + (write-nchar #\_ (+ 1 end-column (- note-max-depth (length note-stack) 1)) stream) + (format stream "~C ~A~%" (note-highlight-char note) (message note))))) + +(defun print-finished-notes-for-line (stream printer-state line-number) + (with-slots (note-stack) printer-state + ;; Check if there are any multiline notes that need to be printed + (loop :for stack-head := note-stack :then (cdr stack-head) + :for note := (car stack-head) + :for end-line := (and note (end-line printer-state note)) + :when (null stack-head) + :do (return) + :when (= line-number end-line) + :do (print-note-end stream printer-state note) + :when (and (eq note (car note-stack)) + (>= line-number end-line)) + :do (pop note-stack)))) + +(defun print-lines-until (stream printer-state line-number) + (with-slots (current-line note-stack) printer-state + (cond ((= line-number current-line) + ;; If we are on the same line then don't reprint. + ) + ((>= 3 (- line-number current-line)) + ;; If we are within 3 lines of the previous one then just + ;; print those lines. + (loop :for line :from current-line :below line-number + :do (print-line-contents stream printer-state (1+ line)) + :unless (= (1+ line) line-number) + :do (print-finished-notes-for-line stream printer-state (1+ line)))) + (t + ;; Otherwise split the output. + (print-line-contents stream printer-state (1+ current-line)) + ;; Print out any intermediate multiline note endings. + (loop :for note :in note-stack + :for end-line := (end-line printer-state note) + :when (< current-line end-line line-number) + :do (print-lines-until stream printer-state end-line)) + (format stream " ...~%") + (print-line-contents stream printer-state (1- line-number)) + (print-line-contents stream printer-state line-number))) + (setf current-line line-number))) + +(defun print-note (stream printer-state note) + (multiple-value-bind (start-line end-line) + (location-lines printer-state note) + (print-lines-until stream printer-state start-line) + (cond ((/= start-line end-line) + (print-note-start stream printer-state note) + (push note (note-stack printer-state))) + (t + (print-single-line-note stream printer-state note) + (print-finished-notes-for-line stream printer-state start-line))))) + +(defun print-notes (stream printer-state) + (with-slots (notes last-line) printer-state + (loop :for note :in notes + :do (print-note stream printer-state note)) + (print-lines-until stream printer-state last-line) + (print-finished-notes-for-line stream printer-state last-line))) + +(defun print-help (stream printer-state help) + (with-slots (source-stream) printer-state + (multiple-value-bind (start-line start-column end-line end-column) + (location-positions printer-state help) + (unless (= start-line end-line) + (cl:error "multiline help messages not supported")) + (format stream "help: ~A~%" (message help)) + (let ((line (line-contents printer-state start-line))) + (print-line-prefix stream printer-state :line-number start-line) + (format stream " ~A" (subseq line 0 start-column)) + (let ((replaced-text (funcall (or (replace-function help) #'identity) + (subseq line start-column end-column)))) + (format stream "~A~A~%" replaced-text (subseq line end-column)) + (print-line-prefix stream printer-state) + (format stream "~v{~C~:*~}~v{~C~:*~}~%" + (1+ start-column) '(#\Space) + (length replaced-text) '(#\-))))))) + +(defun print-empty-line (stream printer-state) + (print-line-prefix stream printer-state) + (terpri stream)) + +(defun %reduce-context (context) + (mapcar #'cdr + (reduce (lambda (acc context) + (if (assoc (car context) acc) + acc + (cons context acc))) + context + :initial-value nil))) + +(defun make-printer-state (source-stream condition) + (let* ((all-notes (sort (copy-list (notes condition)) + #'< :key #'start-offset)) + (notes (remove-if #'note-help-p all-notes)) + (help (remove-if-not #'note-help-p all-notes))) + (make-instance 'printer-state + :source-stream source-stream + :notes notes + :help help + :context (%reduce-context (context condition))))) + +(defun condition-stream (condition) + (source-stream (location-source (location (first (notes condition)))))) + +(defun report-source-condition (condition stream) + (with-open-stream (source-stream (condition-stream condition)) + (let ((state (make-printer-state source-stream condition))) + (print-condition-location stream state condition) + (print-empty-line stream state) + (with-slots (help context last-line) state + (print-notes stream state) + (loop :for help :in help + :do (print-help stream state help)) + (loop :for context :in context + :do (format stream "note: ~A~%" context)))))) + +;; API + +(define-condition source-condition () + ((message :initarg :message + :reader message) + (notes :initarg :notes + :reader notes) + (context :initform *context* + :reader context)) + (:report report-source-condition)) + +(define-condition source-error (source-condition cl:error) + () + (:documentation "A user-facing error.")) + +(defmethod severity ((condition source-error)) + :error) (defun error (message note &rest notes) "Signal an error related to one or more source locations" - (cl:error 'se:source-base-error - :err (make-source-error ':error message (cons note notes)))) + (cl:error 'source-error + :message message + :notes (cons note notes))) + +(define-condition source-warning (source-condition warning) + () + (:documentation "A user-facing warning.")) + +(defmethod severity ((condition source-warning)) + :warn) (defun warn (message note &rest notes) "Signal a warning related to one or more source locations." - (cl:warn 'se:source-base-warning - :err (make-source-error ':warn message (cons note notes)))) + (cl:warn 'source-warning + :message message + :notes (cons note notes))) diff --git a/src/typechecker/base.lisp b/src/typechecker/base.lisp index 626c822d..9313c1a6 100644 --- a/src/typechecker/base.lisp +++ b/src/typechecker/base.lisp @@ -3,7 +3,6 @@ #:cl) (:local-nicknames (#:source #:coalton-impl/source) - (#:se #:source-error) (#:util #:coalton-impl/util)) (:export #:*coalton-pretty-print-tyvars* @@ -12,9 +11,9 @@ #:*pprint-variable-symbol-suffix* #:tc-error ; CONDITION, FUNCTION #:tc-location - #:tc-primary-location + #:tc-secondary-location #:tc-note - #:tc-primary-note + #:tc-secondary-note #:coalton-internal-type-error ; CONDITION #:check-duplicates ; FUNCTION #:check-package ; FUNCTION @@ -70,24 +69,24 @@ This requires a valid PPRINT-VARIABLE-CONTEXT") (with-pprint-variable-context () (apply #'format nil format-string format-args)))) -(defun tc-primary-location (location format-string &rest format-args) - (source:primary-note location +(defun tc-secondary-location (location format-string &rest format-args) + (source:secondary-note location (with-pprint-variable-context () (apply #'format nil format-string format-args)))) (defun tc-note (located format-string &rest format-args) (apply #'tc-location (source:location located) format-string format-args)) -(defun tc-primary-note (located format-string &rest format-args) - (apply #'tc-primary-location (source:location located) format-string format-args)) +(defun tc-secondary-note (located format-string &rest format-args) + (apply #'tc-secondary-location (source:location located) format-string format-args)) -(define-condition tc-error (se:source-base-error) +(define-condition tc-error (source:source-error) ()) (defun tc-error (message &rest notes) "Signal a typechecker error with MESSAGE, and optional NOTES that label source locations." (declare (type string message)) - (error 'tc-error :err (source:make-source-error ':error message notes))) + (error 'tc-error :message message :notes notes)) (define-condition coalton-internal-type-error (error) () @@ -139,10 +138,9 @@ source locations whose spans are compared for ordering." :do (check-type id symbol) :unless (equalp (symbol-package id) *package*) - :do (tc-located-error - (funcall source elem) - "Invalid identifier name" - (format nil "The symbol ~S is defined in the package ~A and not the current package ~A" - id - (symbol-package id) - *package*)))) + :do (tc-error "Invalid identifier name" + (tc-location (funcall source elem) + "The symbol ~S is defined in the package ~A and not the current package ~A" + id + (symbol-package id) + *package*)))) diff --git a/src/typechecker/define-class.lisp b/src/typechecker/define-class.lisp index e9ec88e3..110362d1 100644 --- a/src/typechecker/define-class.lisp +++ b/src/typechecker/define-class.lisp @@ -67,8 +67,8 @@ (tc:tc-error "Duplicate class definition" (tc:tc-location (parser:toplevel-define-class-head-location first) "first definition here") - (tc:tc-primary-location (parser:toplevel-define-class-head-location second) - "second definition here")))) + (tc:tc-location (parser:toplevel-define-class-head-location second) + "second definition here")))) ;; Check for duplicate method definitions (check-duplicates @@ -78,7 +78,7 @@ (lambda (first second) (tc:tc-error "Duplicate method definition" (tc:tc-note first "first definition here") - (tc:tc-primary-note second "second definition here")))) + (tc:tc-note second "second definition here")))) (loop :for class :in classes :do ;; Classes cannot have duplicate variables @@ -89,7 +89,7 @@ (lambda (first second) (tc:tc-error "Duplicate class variable" (tc:tc-note first "first usage here") - (tc:tc-primary-note second "second usage here"))))) + (tc:tc-note second "second usage here"))))) (let* ((class-table (loop :with table := (make-hash-table :test #'eq) @@ -144,8 +144,8 @@ (cons (tc:tc-location (parser:toplevel-define-class-head-location (first scc)) "in class defined here") (loop :for class :in (rest scc) - :collect (tc:tc-primary-location (parser:toplevel-define-class-head-location class) - "in class defined here"))))) + :collect (tc:tc-location (parser:toplevel-define-class-head-location class) + "in class defined here"))))) :append (multiple-value-bind (classes env_) (infer-class-scc-kinds scc env) diff --git a/src/typechecker/define-instance.lisp b/src/typechecker/define-instance.lisp index f120a691..12dbdad4 100644 --- a/src/typechecker/define-instance.lisp +++ b/src/typechecker/define-instance.lisp @@ -214,7 +214,7 @@ (lambda (first second) (tc-error "Duplicate method definition" (tc-note first "first definition here") - (tc-primary-note second "second definition here")))) + (tc-note second "second definition here")))) ;; Ensure each method is part for the class (loop :for method :in (parser:toplevel-define-instance-methods unparsed-instance) diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp index 35d08ada..7ed8e5f6 100644 --- a/src/typechecker/define-type.lisp +++ b/src/typechecker/define-type.lisp @@ -105,7 +105,7 @@ (lambda (first second) (tc:tc-error "Duplicate type definitions" (tc:tc-note first "first definition here") - (tc:tc-primary-note second "second definition here")))) + (tc:tc-note second "second definition here")))) ;; Ensure that there are no duplicate constructors ;; NOTE: structs define a constructor with the same name @@ -117,7 +117,7 @@ (lambda (first second) (tc:tc-error "Duplicate constructor definitions" (tc:tc-note first "first definition here") - (tc:tc-primary-note second "second definition here")))) + (tc:tc-note second "second definition here")))) ;; Ensure that no type has duplicate type variables (loop :for type :in (append types structs) @@ -128,7 +128,7 @@ (lambda (first second) (tc:tc-error "Duplicate type variable definitions" (tc:tc-note first "first definition here") - (tc:tc-primary-note second "second definition here"))))) + (tc:tc-note second "second definition here"))))) (let* ((type-names (mapcar (alexandria:compose #'parser:identifier-src-name #'parser:type-definition-name) diff --git a/src/typechecker/define.lisp b/src/typechecker/define.lisp index 9e781d66..cc4d3801 100644 --- a/src/typechecker/define.lisp +++ b/src/typechecker/define.lisp @@ -523,10 +523,10 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (setf subs (tc:unify subs ty1 ty2)) (tc:coalton-internal-type-error () (tc-error "Return type mismatch" - (tc-primary-note s1 + (tc-note s1 "First return is of type '~S'" (tc:apply-substitution subs ty1)) - (tc-primary-note s2 + (tc-note s2 "Second return is of type '~S'" (tc:apply-substitution subs ty2)))))) @@ -536,10 +536,10 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (setf subs (tc:unify subs (cdr (first *returns*)) body-ty)) (tc:coalton-internal-type-error () (tc-error "Return type mismatch" - (tc-primary-note (car (first *returns*)) + (tc-note (car (first *returns*)) "First return is of type '~S'" (tc:apply-substitution subs (cdr (first *returns*)))) - (tc-primary-note (parser:node-body-last-node (parser:node-abstraction-body node)) + (tc-note (parser:node-body-last-node (parser:node-abstraction-body node)) "Second return is of type '~S'" (tc:apply-substitution subs body-ty)))))) @@ -575,7 +575,7 @@ Returns (VALUES INFERRED-TYPE PREDICATES NODE SUBSTITUTIONS)") (lambda (first second) (tc-error "Duplicate definition in let" (tc-note first "first definition here") - (tc-primary-note second "second definition here")))) + (tc-note second "second definition here")))) (multiple-value-bind (preds accessors binding-nodes subs) (infer-let-bindings (parser:node-let-bindings node) (parser:node-let-declares node) subs env) @@ -1501,7 +1501,7 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (lambda (first second) (tc-error "Duplicate pattern variable" (tc-note first "first definition here") - (tc-primary-note second "second definition here")))) + (tc-note second "second definition here")))) (unless ctor (tc-error "Unknown constructor" @@ -1866,7 +1866,8 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (tc-note (parser:binding-name first-fn) "function can not be defined recursively with variables") (loop :for binding :in (remove first-fn bindings :test #'eq) - :collect (tc-note (parser:binding-name binding) "with definition"))))) + :collect (tc-secondary-note (parser:binding-name binding) + "with definition"))))) ;; If there is a single non-recursive binding then it is valid (when (and (= 1 (length bindings)) @@ -1883,8 +1884,8 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (tc-note (parser:binding-name (first bindings)) "invalid recursive variable bindings") (loop :for binding :in (rest bindings) - :collect (tc-note (parser:binding-name binding) - "with definition")))) + :collect (tc-secondary-note (parser:binding-name binding) + "with definition")))) (let ((binding-names (mapcar (alexandria:compose #'parser:node-variable-name #'parser:binding-name) @@ -2180,9 +2181,9 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (tc-location s1 "First return is of type '~S'" (tc:apply-substitution subs ty1)) - (tc-primary-location s2 - "Second return is of type '~S'" - (tc:apply-substitution subs ty2)))))) + (tc-location s2 + "Second return is of type '~S'" + (tc:apply-substitution subs ty2)))))) ;; Unify the function's inferred type with one of the early returns. (when *returns* @@ -2193,9 +2194,9 @@ Returns (VALUES INFERRED-TYPE NODE SUBSTITUTIONS)") (tc-location (car (first *returns*)) "First return is of type '~S'" (tc:apply-substitution subs (cdr (first *returns*)))) - (tc-primary-note (parser:binding-last-node binding) - "Second return is of type '~S'" - (tc:apply-substitution subs ret-ty)))))) + (tc-note (parser:binding-last-node binding) + "Second return is of type '~S'" + (tc:apply-substitution subs ret-ty)))))) value-node)) diff --git a/tests/error-tests.lisp b/tests/error-tests.lisp index c7fb4680..066e8b47 100644 --- a/tests/error-tests.lisp +++ b/tests/error-tests.lisp @@ -3,13 +3,8 @@ ;; Test that error messages containing source spans are correctly ;; printed. -(deftest test-error () - (uiop:with-temporary-file (:stream output-stream - :pathname program-file - :suffix "coalton" - :direction :output) - ;; input text - (write-string " ;; +(defvar *error-test-program* + " ;; ;; Kinds ;; @@ -26,41 +21,32 @@ (and (== a1 b1) (== a2 b2))) (_ False)))) -" - output-stream) - :close-stream - (let* ((source (source:make-source-file program-file :name "file")) - (msg (with-output-to-string (output) - ;; an annotating error - (se:display-source-error - output - (se:source-error - :span '(76 . 321) - :source source - :message "message" - :primary-note "define instance form" - :notes (list - (se:make-source-error-note - :type :secondary - :span '(132 . 319) - :message "message 2") - (se:make-source-error-note - :type :secondary - :span '(140 . 145) - :message "message 3") - (se:make-source-error-note - :type :secondary - :span '(170 . 174) - :message "message 4")) - :help-notes - (list - (se:make-source-error-help - :span '(289 . 291) - :replacement (lambda (existing) - (concatenate 'string "*" existing "*")) - :message "message 5"))))))) - ;; output text - (is (string= msg "error: message +") + +(deftest test-error () + (let* ((source (source:make-source-string *error-test-program* :name "file")) + (msg (with-output-to-string (output) + ;; an annotating error + (handler-case + (source:error "message" + (source:note (source:make-location source '(76 . 321)) + "define instance form") + (source:secondary-note (source:make-location source '(132 . 319)) + "message 2") + (source:secondary-note (source:make-location source '(140 . 145)) + "message 3") + (source:secondary-note (source:make-location source '(170 . 174)) + "message 4") + (source:help (source:make-location source '(289 . 291)) + (lambda (existing) + (concatenate 'string "*" existing "*")) + "message 5")) + (source:source-error (c) + (princ c output)))))) + ;; output text + (is (check-string= "error printer" + msg + "error: message --> file:9:2 | 9 | (define-instance (Eq Kind) @@ -80,4 +66,4 @@ help: message 5 16 | (*==* a2 b2))) | ---- -"))))) +")))) diff --git a/tests/package.lisp b/tests/package.lisp index 994f0f81..d3ca3f4f 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -5,7 +5,6 @@ (:use #:cl) (:local-nicknames - (#:se #:source-error) (#:util #:coalton-impl/util) (#:parser #:coalton-impl/parser) (#:source #:coalton-impl/source) diff --git a/tests/parser/cursor-tests.lisp b/tests/parser/cursor-tests.lisp index f5e9d284..8e4fad09 100644 --- a/tests/parser/cursor-tests.lisp +++ b/tests/parser/cursor-tests.lisp @@ -4,7 +4,6 @@ (:local-nicknames (#:parser #:coalton-impl/parser) (#:source #:coalton-impl/source) - (#:se #:source-error) (#:cursor #:coalton-impl/parser/cursor) (#:cst #:concrete-syntax-tree))) @@ -12,7 +11,7 @@ (defun make-cursor (string) (let ((source (source:make-source-string string))) - (with-open-stream (stream (se:source-stream source)) + (with-open-stream (stream (source:source-stream source)) (parser:with-reader-context stream (cursor:make-cursor (parser:maybe-read-form stream parser::*coalton-eclector-client*) source @@ -27,11 +26,3 @@ (is (cursor:empty-p c)) (signals parser:parse-error (cursor:next c)))) - -(deftest collect-symbols () - (let ((c (make-cursor "(a b c)"))) - (is (equal '(a b c) - (cursor:collect-symbols c)))) - - (signals parser:parse-error - (cursor:collect-symbols (make-cursor "(a () c)")))) diff --git a/tests/reader-tests.lisp b/tests/reader-tests.lisp index 209e3ece..9240ac9b 100644 --- a/tests/reader-tests.lisp +++ b/tests/reader-tests.lisp @@ -22,8 +22,7 @@ (is nil "error was not signalled")) (coalton-impl/parser/base:parse-error (c) (is (string= "Invalid variable" - (source-error/error::source-error-message - (source-error:source-condition-err c))) + (source:message c)) "condition message is correct") (is (princ-to-string c) "condition prints without error"))) @@ -36,6 +35,5 @@ (eval (read-from-string "(coalton (add-3 \"two\"))")) (coalton-impl/typechecker/base:tc-error (c) (is (string= "Type mismatch" - (source-error/error::source-error-message - (source-error:source-condition-err c))) + (source:message c)) "condition message is correct"))))) diff --git a/tests/toplevel-tests.lisp b/tests/toplevel-tests.lisp index 7173b554..033def8a 100644 --- a/tests/toplevel-tests.lisp +++ b/tests/toplevel-tests.lisp @@ -1,14 +1,17 @@ (in-package #:coalton-tests) -(defun check-package (string fn) - "Parse the package form present in STRING." +(defun parse-form (string fn) + "Parse the form in STRING." (let ((source (source:make-source-string string :name "test"))) - (with-open-stream (stream (source-error:source-stream source)) + (with-open-stream (stream (source:source-stream source)) (parser:with-reader-context stream - (let* ((form (parser:maybe-read-form stream parser::*coalton-eclector-client*)) - (package (coalton-impl/parser/toplevel::parse-package - (coalton-impl/parser/cursor:make-cursor form source "Unit Test")))) - (funcall fn package)))))) + (funcall fn (parser:maybe-read-form stream parser::*coalton-eclector-client*) source))))) + +(defun parse-package (string) + (parse-form string + (lambda (form source) + (coalton-impl/parser/toplevel::parse-package + (coalton-impl/parser/cursor:make-cursor form source "Unit Test"))))) (deftest test-lisp-package () "Lisp packages can be constructed from parsed Coalton package forms." @@ -27,32 +30,29 @@ (del-pkg 'coalton-unit-test/package-a) (del-pkg 'coalton-unit-test/package-c) - (check-package - "(package coalton-unit-test/package-a - (export a b c))" - (lambda (pkg-a) - (let ((lisp-pkg-a (coalton-impl/parser/toplevel::lisp-package pkg-a))) - (is (= 3 (length (ext-syms lisp-pkg-a)))) - (is (equal '("COALTON") - (use-pkgs lisp-pkg-a)))))) + (let* ((pkg-a (parse-package + "(package coalton-unit-test/package-a + (export a b c))")) + (lisp-pkg-a (coalton-impl/parser/toplevel::lisp-package pkg-a))) + (is (= 3 (length (ext-syms lisp-pkg-a)))) + (is (equal '("COALTON") + (use-pkgs lisp-pkg-a)))) - (check-package + (let* ((pkg-b (parse-package "(package coalton-unit-test/package-b (import coalton-unit-test/package-a (coalton-library/list as list)) - (export d e f))" - (lambda (pkg-b) - (let ((lisp-pkg-b (coalton-impl/parser/toplevel::lisp-package pkg-b))) - (is (= 3 (length (ext-syms lisp-pkg-b)))) - (is (equal '("COALTON" "COALTON-UNIT-TEST/PACKAGE-A") - (use-pkgs lisp-pkg-b)))))) + (export d e f))")) + (lisp-pkg-b (coalton-impl/parser/toplevel::lisp-package pkg-b))) + (is (= 3 (length (ext-syms lisp-pkg-b)))) + (is (equal '("COALTON" "COALTON-UNIT-TEST/PACKAGE-A") + (use-pkgs lisp-pkg-b)))) - (check-package + (let* ((pkg-c (parse-package "(package coalton-unit-test/package-c - (shadow not))" - (lambda (pkg-c) - (let ((lisp-pkg-c (coalton-impl/parser/toplevel::lisp-package pkg-c))) - (is (= 1 (length (package-shadowing-symbols lisp-pkg-c)))) - (is (equal "NOT" - (symbol-name (first - (package-shadowing-symbols lisp-pkg-c)))))))))) + (shadow not))")) + (lisp-pkg-c (coalton-impl/parser/toplevel::lisp-package pkg-c))) + (is (= 1 (length (package-shadowing-symbols lisp-pkg-c)))) + (is (equal "NOT" + (symbol-name (first + (package-shadowing-symbols lisp-pkg-c)))))))) diff --git a/tests/utilities.lisp b/tests/utilities.lisp index fc434b39..6e068248 100644 --- a/tests/utilities.lisp +++ b/tests/utilities.lisp @@ -37,7 +37,7 @@ :use '("COALTON" "COALTON-PRELUDE")))) (unwind-protect (let ((source (source:make-source-string toplevel-string))) - (with-open-stream (stream (se:source-stream source)) + (with-open-stream (stream (source:source-stream source)) (let ((program (parser:with-reader-context stream (parser:read-program stream source)))) @@ -49,7 +49,7 @@ (loop :for (unparsed-symbol . unparsed-type) :in expected-types :do (let ((symbol (intern (string-upcase unparsed-symbol) *package*)) (source (source:make-source-string unparsed-type))) - (with-open-stream (stream (se:source-stream source)) + (with-open-stream (stream (source:source-stream source)) (let* ((ast-type (parser:parse-qualified-type (eclector.concrete-syntax-tree:read stream) source)) @@ -106,7 +106,7 @@ Returns (values SOURCE-PATHNAME COMPILED-PATHNAME)." (signal c))))) (entry:compile source) nil) - (se:source-base-warning (c) + (source:source-warning (c) (string-trim '(#\Space #\Newline) (princ-to-string c))) (error (c)