;; -*- Mode: Lisp; -*- ;; --------------------------------------------------------------------------- ;; Title: Parsing Framework, second attempt ;; Created: 2023-02-23 ;; Author: Gilbert Baumann ;; License: MIT style (see below) ;; --------------------------------------------------------------------------- ;; (c) copyright 2023 by Gilbert Baumann ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :cl-user) #+(or) (defpackage :parse2 (:use :clex2 :de.bauhh.lalr :cl) (:shadowing-import-from #:de.bauhh.define-grammar #:define-grammar #:FANCY-LALR-TABLE) (:import-from #:de.bauhh.define-grammar #:compile-define-grammar-1) (:import-from #:de.bauhh.lalr #:shift-action #:shift-action-p #:shift-action-goto #:reduce-action #:reduce-action-p #:reduce-action-goto #:reduce-action-function #:*TOPCAT*) ;Hmm (:export #:parse) ) #+(or) (in-package :parse2) (in-package :nyala) ;;;; ------------------------------------------------------------------------------------------ ;; (:DRIVER ) ;; ;; Driver to use to parse. Default is LALR-PARSE. ;; ;; It is a function passed the LALR table, a function for getting ;; the next token, and a vector of actions. ;; ;; (:TRANSDUCER ) ;; ;; A function taking the scanner function and returning an alternate ;; scanner function. ;; ;; (:LEXER-FUNCTION ) ;; ;; Function to use to get a scanner function. It is applied to ;; /input-args/ to yield the scanner function, which upon each call ;; should return the next token as two values category and semantic ;; value. ;; ;; (:NO-AUTO-TOKEN-PATTERN ) ;; ;; On default each string in the grammar is turned into a lexer rule ;; matching exactly that string. While this is fine for punctuation ;; it might turn out expensive for reserved words, which are usually ;; of identifier syntax and are best handled while interning ;; identifiers. ;; ;; The :NO-AUTO-TOKEN-PATTERN allows to specify a pattern that when ;; matched shunts a string from being turned into a literal lexer ;; rule. Such strings still turn lexical categories named by keywords ;; by default. But see the :INTERN-KEYWORD option on how to override ;; that. ;; ;; (:INTERN-KEYWORD ) ;; ;; Function to map literal strings in the grammar into atom naming ;; lexical categories. The result does not need to be a keyword or ;; even a symbol, any atom suffices and EQL is used for matching. ;; ;; (:CONFLICT-RESOLVER ) ;; (:precedence) ;; (:tokens) ;; CLEX2 itself comes with a lot of options. ;; ;;;; -- TODO ---------------------------------------------------------------------------------- ;; (:lexer-function fun) ;; (:lexer-macro name) ;; (:driver-function ...) ;; - Some means to have keywords go through a hash. But that is so ;; custom and fragile that we may not want make this a public API. ;; - And while we are at it. Why cannot we have $1.1 $1.2 etc to refer ;; to aux values. ;; How about: ;; (:reserved-word-pattern ) ;; (:reserved-word-intern ) ;;; ;; Somehting else would be the following. Let the user specifiy a ;; routine which interns keywords. ;; (:resvered-word-pattern "[a-zA-Z0-9]+") ;; (:resvered-word-intern (lambda (s) (intern s :keyword))) ;; ;;;; ------------------------------------------------------------------------------------------ ;; We need a front-end to DEFINE-GRAMMAR #+NIL (defmacro parse ((input &rest input-args &key &allow-other-keys) &body body &aux (input-args (cons input input-args)) &environment env) (multiple-value-bind (driver table lexer actions) (compile-parser body input-args env) `(,driver ',table ,lexer (VECTOR ,@actions)))) (defmacro parse ((input &rest input-args &key &allow-other-keys) &body body &environment env) (let ((g.input (gensym)) (g.aux (gensym))) `(labels ((,g.aux (,g.input) ,(multiple-value-bind (driver table lexer actions) (compile-parser body (cons g.input input-args) env) `(,driver ',table ,lexer (VECTOR ,@actions))))) (let ((,g.input ,input)) (etypecase ,g.input ((or string stream) (,g.aux ,g.input)) (pathname (with-open-file (,g.input ,g.input) (,g.aux ,g.input)))))))) (defmacro define-parser (name &body body &aux (input-args '(input)) &environment env) (multiple-value-bind (driver table lexer actions) (compile-parser body input-args env) (unless (eq 'lalr-parse driver) (warn "You're not supposed to specify a driver with ~S." 'define-parser)) `(progn (setf (get ',name 'lalr-table) ',table) (setf (get ',name 'scanner) (lambda (input) ,lexer)) (setf (get ',name 'actions) (vector ,@actions)) ',name))) (defun compile-parser (body input-args &optional env) ;; First thing: We partition into lexer rules and grammar rules (multiple-value-bind (grammar-rules lexer-rules) (labels ((grammar-rule-p (rule) (or (member (car rule) '(:precedence :tokens :driver :transducer :lexer-function :no-auto-token-pattern :define-lexer :conflict-resolver :intern-keyword)) (and (not (keywordp (car rule))) ;lexical categories (not (symbol= '#:= (car rule))) ;lexer macros (not (symbol= '#:-> (car rule))))))) ;ignore lexer rules (values (remove-if-not #'grammar-rule-p body) (remove-if #'grammar-rule-p body))) (let ((driver 'LALR-PARSE) (transducer nil) (lexer-function nil) (no-auto-token-pattern nil) (intern-keyword nil) (conflict-resolver nil)) (setq grammar-rules (mapcan (lambda (g) (cond ((and (consp g) (eq (car g) ':driver)) (destructuring-bind (driver-arg) (cdr g) (setq driver driver-arg)) nil) ((and (consp g) (eq (car g) ':transducer)) (destructuring-bind (arg) (cdr g) (setq transducer arg)) nil) ((and (consp g) (eq (car g) ':lexer-function)) (destructuring-bind (arg) (cdr g) (setq lexer-function arg)) nil) ((and (consp g) (eq (car g) ':no-auto-token-pattern)) (destructuring-bind (arg) (cdr g) (setq no-auto-token-pattern arg)) nil) ((and (consp g) (eq (car g) ':intern-keyword)) (destructuring-bind (arg) (cdr g) (setq intern-keyword arg)) nil) ((and (consp g) (eq (car g) ':conflict-resolver)) (destructuring-bind (arg) (cdr g) (setq conflict-resolver arg)) nil) (t (list g)))) grammar-rules)) ;; Rest is dead easy. (multiple-value-bind (table tokens actions) (let ((*intern-keyword* (if intern-keyword (enclose-function intern-keyword env) *intern-keyword*)) (*conflict-resolver* (and conflict-resolver (enclose-function conflict-resolver env)))) (compile-define-grammar-1 grammar-rules)) (let* ((lexer (if lexer-function `(funcall ,lexer-function ,@input-args) `(LEXER (,@input-args) ,@(mapcan (lambda (token) (and (cdr token) (destructuring-bind (cat . text) token (cond ((and no-auto-token-pattern (clex2:scan no-auto-token-pattern text :anchored t)) ;; (warn "No automatic rule for ~S" token) nil) (t (list `(-> ',text => (return (values ',cat ',cat))))))))) tokens) ,@lexer-rules))) (lexer (if transducer `(,transducer ,lexer) lexer))) (values driver table lexer actions)))))) (defun symbol= (symbol-1 symbol-2) (and (symbolp symbol-1) (symbolp symbol-2) (string= symbol-1 symbol-2))) #+CCL (defun enclose (lambda-expression &optional env) (ccl:enclose lambda-expression env)) #-CCL (defun enclose (lambda-expression &optional env) (declare (ignore env)) (compile nil lambda-expression)) (defun enclose-function (function &optional env) (etypecase function (symbol (symbol-function function)) ((cons (member LAMBDA)) (enclose function env)) ((cons (member FUNCTION)) (destructuring-bind (function) (cdr function) (etypecase function (symbol (symbol-function function)) ((cons (member LAMBDA)) (enclose function env)))))))