Skip to content
meta-src.lisp 8.48 KiB
Newer Older
;;;;										;
;;;; (c) 2001 by Jochen Schmidt.
;;;;
;;;; File:            meta.lisp
;;;; Revision:        1.0.0
;;;; Description:     A simple parsing technique
;;;; Date:            01.07.2001
;;;; Authors:         Jochen Schmidt
;;;; Tel:             (+49 9 11) 47 20 603
;;;; Email:           jsc@dataheaven.de
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above copyright
;;;;    notice, this list of conditions and the following disclaimer in the
;;;;    documentation and/or other materials provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER
;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT
;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
;;;; AND FITNESS FOR A PARTICULAR PURPOSE. IN NO WAY ARE THE
;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES,
;;;; LOSS OF USE, DATA, OR PROFITS OR BUSINESS INTERRUPTION)
;;;;
;;;; For further details contact the authors of this software.
;;;;
;;;;  Jochen Schmidt
;;;;  Zuckmantelstr. 11
;;;;  91616 Neusitz
;;;;  GERMANY
;;;;
;;;;
;;;; NOTE:
;;;; This code is based on the well known paper "Pragmatic Parsing in Common Lisp"
;;;; of Henry G. Baker. You can find it at:
;;;;
;;;;    http://linux.rice.edu/~rahul/hbaker/Prag-Parse.html
;;;;
;;;; The parsing technique Baker describes in his paper goes back to:
;;;;
;;;;     Schorre, D.V.  "META II: A Syntax-Oriented Compiler Writing Language".
;;;;       Proc. 19'th Nat'l. Conf. of the ACM (Aug. 1964),D1.3-1-D1.3-11.
;;;;
;;;;
;;;; Nuernberg, 01.Jul.2001 Jochen Schmidt
#+xcvb (module (:depends-on ("package")))

(in-package :meta)


;;; String matching
(defmacro string-match (x &key source-symbol)
  (etypecase x
    (character
     `(when (and (< index end) (eql (char ,source-symbol index)  ,x))
        (incf index)))
    (string
     (let ((old-index-symbol (gensym "OLD-INDEX-")))
       `(let ((,old-index-symbol index))
          (or (and ,@(map 'list #'(lambda (c) `(string-match ,c
                                                             :source-symbol ',source-symbol)) x))
              (progn (setq index ,old-index-symbol) nil)))))))

(defmacro string-match-type (x v &key source-symbol)
  (let ((char-sym (gensym)))
    `(when (< index end)
       (let ((,char-sym (char ,source-symbol index)))
         (declare (base-char ,char-sym))
         (when (typep ,char-sym ',x)
           (setq ,v ,char-sym) (incf index))))))


;;; List matching
(defmacro list-match (x &key source-symbol); sublist uses new lexical index
 `(when (and (consp ,source-symbol)
             ,(if (atom x) `(eql (car ,source-symbol) ',x)
                `(let ((,source-symbol (car ,source-symbol))) ,(compile-list x :source-symbol source-symbol))))
    (pop ,source-symbol) t))

(defmacro list-match-type (x v &key source-symbol)
  `(when (and (consp ,source-symbol) (typep (car ,source-symbol) ',x))
     (setq ,v (car ,source-symbol)) (pop ,source-symbol) t))

(defun compile-list (l &key source-symbol)
  (if (atom l) `(eql ,source-symbol ',l)
      `(and ,(compileit (car l) :meta-parser-type :list :source-symbol source-symbol)
            ,(compile-list (cdr l) :source-symbol source-symbol))))


;;; Stream matching
(defmacro stream-match (x &key source-symbol)
  `(when (eql (peek-char nil ,source-symbol) ',x) (read-char ,source-symbol)))

(defmacro stream-match-type (x v &key source-symbol)
  `(when (typep (peek-char nil ,source-symbol) ',x) (setq ,v (read-char ,source-symbol))))

(defstruct (meta
            (:print-function
             (lambda (m s d &aux (char (meta-char m)) (form (meta-form m)))
               (declare (ignore d))
               (ecase char
                 ((#\@ #\! #\$) (format s "~A~A" char form))
                 (#\[ (format s "[~{~A~^ ~}]" form))
                 (#\{ (format s "{~{~A~^ ~}}" form))))))
    char
    form)

(defmethod make-load-form ((m meta) #-genera &optional #-genera environment)
  #-genera (declare (ignore environment))
  `(make-meta :char ,(meta-char m) :form ',(meta-form m)))


(defun compileit (x &key meta-parser-type source-symbol)
  (typecase x
    (meta
     (ecase (meta-char x)
       (#\! (meta-form x))
       (#\[ `(and ,@(mapcar #'(lambda (f) (compileit f
                                                     :meta-parser-type meta-parser-type
                                                     :source-symbol source-symbol))
                            (meta-form x))))
       (#\{ `(or ,@(mapcar #'(lambda (f) (compileit f
                                                    :meta-parser-type meta-parser-type
                                                    :source-symbol source-symbol))
                           (meta-form x))))
       (#\$ `(not (do () ((not ,(compileit (meta-form x)
                                           :meta-parser-type meta-parser-type
                                           :source-symbol source-symbol))))))
       (#\@ (let ((f (meta-form x))) (list (ecase meta-parser-type
                                             (:list 'list-match-type)
                                             (:string 'string-match-type)
                                             (:stream 'stream-match-type))
                                           (car f) (cadr f)
                                           :source-symbol source-symbol)))))
    (t (list (ecase meta-parser-type
               (:list 'list-match)
               (:string 'string-match)
               (:stream 'stream-match))
             x
             :source-symbol source-symbol))))
(defun meta-reader (s c)
  (make-meta :char c :form (read s)))
(defun meta-curly-bracket (s c)
  (make-meta :char c :form (read-delimited-list #\} s t)))
(defun meta-square-bracket (s c)
  (make-meta :char c :form (read-delimited-list #\] s t)))
(defreadtable :meta-mixin
  (:macro-char #\[ #'meta-square-bracket)
  (:macro-char #\{ #'meta-curly-bracket)
  (:syntax-from :standard #\) #\])
  (:syntax-from :standard #\) #\})
  (:macro-char #\@ #'meta-reader)
  (:macro-char #\$ #'meta-reader)
  (:macro-char #\! #'meta-reader))
(defreadtable :meta
  (:fuze :standard :meta-mixin))

(defparameter *saved-readtable* (find-readtable :standard))
(defparameter *meta-readtable* (find-readtable :meta))

(defmacro with-stream-meta ((source-symbol stream) &body body)
  `(let ((,source-symbol ,stream))
     (macrolet ((match (x)
                  (compileit x
                             :meta-parser-type :stream
                             :source-symbol ',source-symbol)))
       ,@body)))

(defmacro with-string-meta ((source-symbol string-buffer &key (start 0) end) &body body)
  `(let* ((,source-symbol ,string-buffer)
          (index ,start)
          (end ,(or end `(length ,source-symbol))))
     (declare (fixnum index end)
                  (compileit x
                             :meta-parser-type :string
                             :source-symbol ',source-symbol)))
       ,@body)))


(defmacro with-list-meta ((source-symbol list) &body body)
  `(let ((,source-symbol ,list))
     (macrolet ((match (x)
                  (compileit x
                             :meta-parser-type :list
                             :source-symbol ',source-symbol)))
       ,@body)))

(defun enable-meta-syntax ()
  (setf *readtable* *meta-readtable*))
(defun disable-meta-syntax ()
  (setf *readtable* *saved-readtable*))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (deftype digit () '(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

  (deftype non-digit () '(not (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))

  (defun ctoi (d) (- (char-code d) #.(char-code #\0)))
)

(eval-when (:compile-toplevel :execute)
  (enable-meta-syntax))

(defun parse-int (string &aux (s +1) d (n 0))
  (with-string-meta (buffer string)
                    (and
                     (match
                      [{#\+ [#\- !(setq s -1)] []}
                            @(digit d) !(setq n (ctoi d))
                            $[@(digit d) !(setq n (+ (* n 10) (ctoi d)))]])
                     (* s n))))

(eval-when (:compile-toplevel :execute)
  (disable-meta-syntax))