src/class-*.lisp: Improve metaclass selection.

[sod] / src / parser / scanner-impl.lisp

;;; -*-lisp-*-
;;;
;;; Basic scanner interface
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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-parser)

;;;--------------------------------------------------------------------------
;;; Common scanner implementation..

(defmethod file-location ((scanner character-scanner))
  (scanner-file-location scanner))

(defmethod file-location ((scanner token-scanner))
  (scanner-file-location scanner))

;;;--------------------------------------------------------------------------
;;; Streams on character scanners.

(defmethod stream-read-char ((stream character-scanner-stream))
  (with-slots (scanner) stream
    (if (scanner-at-eof-p scanner)
	:eof
	(prog1 (scanner-current-char scanner)
	  (scanner-step scanner)))))

(defmethod stream-unread-char ((stream character-scanner-stream) char)
  (with-slots (scanner) stream
    (scanner-unread scanner char)))

(defmethod stream-peek-char ((stream character-scanner-stream))
  (with-slots (scanner) stream
    (scanner-current-char scanner)))

;;;--------------------------------------------------------------------------
;;; String scanner.

;; This is much more convenient for testing lexers than the full character
;; buffer scanner.

(export '(string-scanner make-string-scanner string-scanner-p))
(defstruct (string-scanner
	     (:constructor make-string-scanner
		 (string &key (start 0) end filename
		  &aux (%string string)
		       (index start)
		       (limit (or end (length string))))))
  "Scanner structure for a simple string scanner."
  (%string "" :type string :read-only t)
  (filename "<string>" :type string :read-only t)
  (index 0 :type (and fixnum unsigned-byte))
  (limit nil :type (and fixnum unsigned-byte) :read-only t)
  (line 1 :type fixnum)
  (column 0 :type fixnum))
(define-access-wrapper string-scanner-string string-scanner-%string
		       :read-only t)

(defmethod scanner-at-eof-p ((scanner string-scanner))
  (>= (string-scanner-index scanner) (string-scanner-limit scanner)))

(defmethod scanner-current-char ((scanner string-scanner))
  (char (string-scanner-string scanner) (string-scanner-index scanner)))

(defmethod scanner-step ((scanner string-scanner))
  (let ((index (string-scanner-index scanner)))
    (setf (values (string-scanner-line scanner)
		  (string-scanner-column scanner))
	  (update-position (char (string-scanner-string scanner) index)
			   (string-scanner-line scanner)
			   (string-scanner-column scanner))
	  (string-scanner-index scanner) (1+ index))))

(defmethod scanner-unread ((scanner string-scanner) char)
  (let ((index (1- (string-scanner-index scanner))))
    (setf (values (string-scanner-line scanner)
		  (string-scanner-column scanner))
	  (backtrack-position (char (string-scanner-string scanner) index)
			      (string-scanner-line scanner)
			      (string-scanner-column scanner))
	  (string-scanner-index scanner) index)))

(defmethod scanner-filename ((scanner string-scanner))
  (string-scanner-filename scanner))
(defmethod scanner-line ((scanner string-scanner))
  (string-scanner-line scanner))
(defmethod scanner-column ((scanner string-scanner))
  (string-scanner-column scanner))
(defmethod file-location ((scanner string-scanner))
  (make-file-location (string-scanner-filename scanner)
		      (string-scanner-line scanner)
		      (string-scanner-column scanner)))

(defmethod scanner-capture-place ((scanner string-scanner))
  (string-scanner-index scanner))

(defmethod scanner-restore-place ((scanner string-scanner) place)
  (setf (string-scanner-index scanner) place))

(defmethod scanner-interval
    ((scanner string-scanner) place-a &optional place-b)
  (with-slots ((string %string) index) scanner
    (subseq string place-a (or place-b index))))

(defmethod make-scanner-stream ((scanner string-scanner))
  (make-instance 'character-scanner-stream :scanner scanner))

;;;--------------------------------------------------------------------------
;;; List scanner.

(export '(list-scanner list-scanner-p make-list-scanner))
(defstruct (list-scanner
	     (:constructor make-list-scanner (list &aux (%list list))))
  "Simple token scanner for lists.

   The list elements are the token semantic values; the token types are the
   names of the elements' classes.  This is just about adequate for testing
   purposes, but is far from ideal for real use."
  (%list nil :type list))
(define-access-wrapper list-scanner-list list-scanner-%list)

(defmethod scanner-step ((scanner list-scanner))
  (pop (list-scanner-list scanner)))

(defmethod scanner-at-eof-p ((scanner list-scanner))
  (null (list-scanner-list scanner)))

(defmethod token-type ((scanner list-scanner))
  (class-name (class-of (car (list-scanner-list scanner)))))

(defmethod token-value ((scanner list-scanner))
  (car (list-scanner-list scanner)))

(defmethod scanner-capture-place ((scanner list-scanner))
  (list-scanner-list scanner))

(defmethod scanner-restore-place ((scanner list-scanner) place)
  (setf (list-scanner-list scanner) place))

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