Work in progress. Mostly bug fixing.

[sod] / src / lexer-proto.lisp

;;; -*-lisp-*-
;;;
;;; Protocol for lexical analysis
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Class definition.

(export 'sod-token-scanner)
(defclass sod-token-scanner (token-scanner)
  ((char-scanner :initarg :char-scanner :reader token-scanner-char-scanner))
  (:documentation
   "A token scanner for SOD input files.

   Not a lot here, apart from a character scanner to read from and the
   standard token scanner infrastructure."))

;;;--------------------------------------------------------------------------
;;; Indicators and error messages.

(export 'define-indicator)
(defun define-indicator (indicator description)
  "Associate an INDICATOR with its textual DESCRIPTION.

   Updates the the `*indicator-map*'."
  (setf (gethash indicator *indicator-map*) description)
  indicator)

(export 'syntax-error)
(defun syntax-error (scanner expected &key (continuep t))
  "Signal a (maybe) continuable syntax error."
  (labels ((show-token (type value)
	     (if (characterp type)
		 (format nil "~/sod::show-char/" type)
		 (case type
		   (:id (format nil "<identifier~@[ `~A'~]>" value))
		   (:string "<string-literal>")
		   (:char "<character-literal>")
		   (:eof "<end-of-file>")
		   (:ellipsis "`...'")
		   (t (format nil "<? ~S~@[ ~S~]>" type value)))))
	   (show-expected (thing)
	     (acond ((gethash thing *indicator-map*) it)
		    ((atom thing) (show-token thing nil))
		    ((eq (car thing) :id)
		     (format nil "`~A'" (cadr thing)))
		    (t (format nil "<? ~S>" thing)))))
    (funcall (if continuep #'cerror* #'error)
	     "Syntax error: ~
	      expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
	      but found ~A"
	     (mapcar #'show-expected expected)
	     (show-token (token-type scanner) (token-value scanner)))))

(export 'lexer-error)
(defun lexer-error (char-scanner expected consumedp)
  "Signal a continuable lexical error."
  (cerror* "Lexical error: ~
	    expected ~{~#[<bug>~;~A~;~A or ~A~;:~A, ~]~} ~
	    but found ~/sod::show-char/~
	    ~@[ at ~A~]"
	   (mapcar (lambda (exp)
		     (typecase exp
		       (character (format nil "~/sod::show-char/" exp))
		       (string (format nil "`~A'" exp))
		       ((cons (eql :digit) *) (format nil "<radix-~A digit>"
						      (cadr exp)))
		       ((eql :eof) "<end-of-file>")
		       ((eql :any) "<character>")
		       (t (format nil "<? ~S>" exp))))
		   expected)
	   (and (not (scanner-at-eof-p char-scanner))
		(scanner-current-char char-scanner))
	   (and consumedp (file-location char-scanner))))

;;;--------------------------------------------------------------------------
;;; Lexical analysis utilities.

(defun scan-comment (char-scanner)
  "Scan a comment (either `/* ... */' or `// ...') from CHAR-SCANNER.

   The result isn't interesting."
  (with-parser-context (character-scanner-context :scanner char-scanner)
    (parse (or (and "/*"
		    (and (skip-many ()
			   (and (skip-many () (not #\*))
				(label "*/" (skip-many (:min 1) #\*)))
			   (not #\/))
			 #\/))
	       (and "//"
		    (skip-many () (not #\newline))
		    (? #\newline))))))

;;;----- That's all, folks --------------------------------------------------