;;;; ; ;;;; (c) 2001-2004 by Jochen Schmidt. ;;;; ;;;; File: smeta.lisp ;;;; Revision: 3.0.0 ;;;; Description: A simple parsing technique ;;;; Date: 20.01.2004 ;;;; Authors: Jochen Schmidt ;;;; Tel: (+49 9 11) 47 20 603 ;;;; Email: js@codeartist.org ;;;; ;;;; 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 ;;;; ;;;; Bakers version used reader-macros to define a special syntax ;;;; for the META language. I used an s-expression based syntax ;;;; in this implementation ;;;; ;;;; 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 (defpackage :smeta (:use #:common-lisp) (:export #:with-string-meta #:with-list-meta #:with-stream-meta #:while #:index #:end #:match)) (in-package :smeta) ;;; 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 (character ,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 ,(sexpr-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 ,source-symbol) ',x) (read-char ,source-symbol))) (defmacro stream-match-type (x v &key source-symbol) `(when (typep (peek-char ,source-symbol) ',x) (setq ,v (read-char ,source-symbol)))) (defun sexpr-compileit (x &key meta-parser-type source-symbol) (typecase x (cons (case (intern (symbol-name (car x)) :keyword) (:and `(and ,@(mapcar #'(lambda (f) (sexpr-compileit f :meta-parser-type meta-parser-type :source-symbol source-symbol)) (rest x)))) (:or `(or ,@(mapcar #'(lambda (f) (sexpr-compileit f :meta-parser-type meta-parser-type :source-symbol source-symbol)) (rest x)))) (:while `(not (do () ((not ,(sexpr-compileit (second x) :meta-parser-type meta-parser-type :source-symbol source-symbol)))))) (:type (let ((f (rest x))) (list (ecase meta-parser-type (:list 'list-match-type) (:string 'string-match-type) (:stream 'stream-match-type)) (first f) (second f) :source-symbol source-symbol ))) (otherwise x))) (t (list (ecase meta-parser-type (:list 'list-match) (:string 'string-match) (:stream 'stream-match)) x :source-symbol source-symbol )))) (defmacro with-stream-meta ((source-symbol stream) &body body) `(let ((,source-symbol ,stream)) (macrolet ((match (x) (sexpr-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) (type string ,source-symbol)) (macrolet ((match (x) (sexpr-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) (sexpr-compileit x :meta-parser-type :list :source-symbol ',source-symbol))) ,@body))) #| (eval-when (compile load eval) (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))) ) (defun parse-int (string &aux (s +1) d (n 0)) (with-string-meta (buffer string) (and (match (and (or #\+ (and #\- (setq s -1)) (and)) (type digit d) (setq n (ctoi d)) (while (and (type digit d) (setq n (+ (* n 10) (ctoi d))))))) (* s n)))) |#