;; Copyright (c) 2010 Phil Hargett;; 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:hh-parse);; ---------------------------------------------------------------------------------------------------------------------;;;; Conditions;;;; ---------------------------------------------------------------------------------------------------------------------(define-conditionlexer-error(error)((lexer:initarg:lexer:accessorlexer)(unexpected-character:initformnil:initarg:character:accessorunexpected-character))(:report(lambda(conditionstream)(with-slots(sourcepositionstate)(lexercondition)(formatstream"Unexpected character ~@[~s~] in state ~s at position (line=~a,column=~a)"(unexpected-charactercondition)state(line-atposition)(column-atposition))))));; ---------------------------------------------------------------------------------------------------------------------;;;; Generics;;;; ---------------------------------------------------------------------------------------------------------------------(defgenericnext-token(lexer)(:documentation"Return the next token from the stream, or :eof if at end"))(defgenericcopy-lexer(lexer)(:documentation"Return a copy of the lexer with independent state such that invocations of next-token on the original and the copy progress independently"));; ---------------------------------------------------------------------------------------------------------------------;;;; Functions + methods + macros;;;; ---------------------------------------------------------------------------------------------------------------------;; Source code helpers(defmethodsource-text((lexerlexer))(source-text(sourcelexer)))(defmethod(setfsource-text)(text(lexerlexer));; Drop existing lines(setf(source-text(sourcelexer))text))(defmacrodeflexer(name(&optional(initial-statenil))&resttoken-definitions)"Define a lexer whose class is the provided name, the initial state of the lexer is initial,and token definitions are a set of rules defining the tokens recognized by the lexer. Token definitions should bein the following form: ;; (state character-test token-type &key ((:state next-state) nil) ((:accumulate accumulation-test) nil))where forms WITH an accumulation test expand to: ;; ((and (equal ',state state) (funcall ,character-test c)) ;; (return-accumulated-token ',token-type ,accumulation-test))and forms WITHOUT an accumulation test expand to: ;; ((and (equal ',state state) (funcall ,character-test c)) ;; (return-token ',token-type))In both cases, if next-state is non-nil, then the expanded token rule will causethe lexer to change state after recognizing the token.One helpful feature (for some token types) is that if t is passed for character-test,then the test matches any character--no need to pass in a full lambda just to always return t.An additional helpful feature is that if character-test is a character constantand not a function, then the character-test will be a simple lambda: ;; (lambda (c) (char= ,character-test c))For character tests, the single argument passed into the test is the characterjust read from the lexer's source. For accumulation tests, the single argumentpassed to the test is a lookahead: that is, if the accumulation test returns true, then thischaracter will be read from the lexer stream and consumed; if the accumulationtest returns false, the character is not consumed and accumulation of a tokencompletes. "(let((token-nodes(loopfortokenintoken-definitionscollect(destructuring-bind(statecharacter-testtoken-type&key((:statenext-state)nil)((:accumulateaccumulation-test)nil))token(declare(ignorablestatecharacter-testnext-stateaccumulation-test))`(defclass,token-type(ast-node)()))))(token-rules(loopfortokenintoken-definitionscollect(destructuring-bind(statecharacter-testtoken-type&key((:statenext-state)nil)((:accumulateaccumulation-test)nil))token(let((actual-character-test(cond((equaltcharacter-test)t)((functionpcharacter-test)`(funcall,character-testc))((and(listpcharacter-test)(equal'lambda(carcharacter-test)))`(funcall,character-testc))((and(listpcharacter-test)(equal'function(carcharacter-test)))`(funcall,character-testc))((characterpcharacter-test)`(char=c,character-test))(t(error"Bad character test ~s in token definition: ~s~%"character-testtoken)))))(ifaccumulation-test;; with accumulation test`((and(equal,statestate),actual-character-test),(whennext-state`(setfstate,next-state))(return-accumulated-token',token-type,accumulation-test));; without accumulation test`((and(equal,statestate),actual-character-test),(whennext-state`(setfstate,next-state))(return-token',token-type))))))))`(progn,@token-nodes(defclass,name(lexer)((state:initform,initial-state)))(defmethodnext-token((lexer,name))(with-slots(sourcepositionstate)lexer(let((c(next-lex-charactersourceposition))(token-value(make-array`(0):element-type'character:adjustablet:fill-pointert)))(labels((accumulate(c)(vector-push-extendctoken-value))(return-accumulated-token(typetest)(accumulatec)(loopfornc=(current-lex-charactersourceposition)while(andnc(funcalltestnc))do(progn(accumulatenc)(incf-lex-positionsourceposition))finally(return(listtype(make-instancetype:valuetoken-value)))))(return-token(type)(listtype(make-instancetype:valuec))))(whenc(cond,@token-rules)))))))))(defmethodcopy-lexer((lexerlexer))(with-slots(sourcepositionstatevalue)lexer(make-instance(class-oflexer):sourcesource:positionposition:statestate)))