├── .github └── workflows │ └── test.yml ├── .gitignore ├── Destructuring ├── aux-parameters.lisp ├── concrete-syntax-tree-destructuring.asd ├── condition-generation.lisp ├── condition-reporters-english.lisp ├── conditions.lisp ├── db-defmacro.lisp ├── generic-functions.lisp ├── key-parameters.lisp ├── lambda-list.lisp ├── optional-parameters.lisp ├── parse-macro.lisp ├── required-parameters.lisp ├── rest-parameters.lisp ├── variables.lisp └── whole-parameters.lisp ├── Documentation ├── Makefile ├── chap-basic-use.tex ├── chap-destructuring-lambda-lists.tex ├── chap-future.tex ├── chap-intro.tex ├── chap-lambda-list-parsing.tex ├── chap-lambda-list.tex ├── codify ├── concrete-syntax-tree.bib ├── concrete-syntax-tree.tex ├── logos.tex ├── other-macros.tex ├── part-internals.tex ├── part-user-manual.tex ├── refmacros.tex ├── spec-macros.tex ├── strip-dependence └── tex-dependencies ├── LICENSE ├── Lambda-list ├── Test │ ├── compare-parse-trees.lisp │ ├── packages.lisp │ ├── parsers.lisp │ ├── random-lambda-list.lisp │ ├── test.lisp │ └── unparse.lisp ├── client.lisp ├── concrete-syntax-tree-lambda-list.asd ├── earley-item.lisp ├── earley-state.lisp ├── earley.lisp ├── ensure-proper.lisp ├── grammar-symbols.lisp ├── grammar.lisp ├── lambda-list-keywords.lisp ├── parse-top-levels.lisp ├── parser.lisp ├── scanner-action.lisp ├── standard-grammars.lisp └── unparse.lisp ├── README ├── Source-info ├── concrete-syntax-tree-source-info.asd ├── packages.lisp └── source-info.lisp ├── Test ├── cst-from-expression.lisp ├── packages.lisp ├── quasiquotation.lisp ├── random-expression.lisp ├── random-sources.lisp └── reconstruct.lisp ├── bindings.lisp ├── body.lisp ├── concrete-syntax-tree.asd ├── condition-reporters-english.lisp ├── conditions.lisp ├── cons-cst.lisp ├── cst-from-expression.lisp ├── cst.lisp ├── cstify.lisp ├── declarations.lisp ├── generic-functions.lisp ├── list-structure.lisp ├── listify.lisp ├── packages.lisp ├── quasiquotation.lisp ├── reconstruct.lisp ├── utilities.lisp └── version-string.sexp /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: test 2 | 3 | on: [push] 4 | 5 | jobs: 6 | 7 | test: 8 | runs-on: ubuntu-latest 9 | 10 | steps: 11 | - name: Prepare runner 12 | run: | 13 | DEBIAN_FRONTEND=noninteractive sudo apt-get -qq update \ 14 | && DEBIAN_FRONTEND=noninteractive sudo apt-get -qq --assume-yes install \ 15 | sbcl 16 | 17 | - uses: actions/checkout@v4 18 | 19 | - name: Install quicklisp 20 | run: | 21 | wget https://beta.quicklisp.org/quicklisp.lisp 22 | sbcl --noinform \ 23 | --load quicklisp.lisp \ 24 | --eval '(quicklisp-quickstart:install)' \ 25 | --quit 26 | 27 | - name: Run tests 28 | run: | 29 | sbcl --noinform --dynamic-space-size 4Gb --disable-debugger \ 30 | --load "${HOME}/quicklisp/setup.lisp" \ 31 | --eval '(asdf:initialize-source-registry (quote (:source-registry (:tree "'"$(pwd)"'") :ignore-inherited-configuration)))' \ 32 | --eval '(ql:quickload (list "concrete-syntax-tree/test" "concrete-syntax-tree-lambda-list/test"))' \ 33 | --eval '(let ((*result* t)) 34 | (declare (special *result*)) 35 | (mapc (quote asdf:test-system) (list "concrete-syntax-tree" "concrete-syntax-tree-lambda-list")) 36 | (uiop:quit (if *result* 0 1)))' 37 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.bbl 3 | *.blg 4 | *.cb 5 | *.cb2 6 | *.idx 7 | *.ilg 8 | *.ind 9 | *.log 10 | *.out 11 | *.pdf 12 | *.toc -------------------------------------------------------------------------------- /Destructuring/aux-parameters.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod aux-parameter-bindings 4 | (client (parameter aux-parameter)) 5 | (declare (ignore client)) 6 | (let ((name (raw (name parameter))) 7 | (form (form parameter))) 8 | `((,name ,(if (cl:null form) cl:nil (raw form)))))) 9 | 10 | (defmethod aux-parameters-bindings 11 | (client (parameters cl:null)) 12 | (declare (ignore client)) 13 | nil) 14 | 15 | (defmethod aux-parameters-bindings 16 | (client (parameters cl:cons)) 17 | (loop for parameter in parameters 18 | appending (aux-parameter-bindings client parameter))) 19 | 20 | (defmethod parameter-group-bindings 21 | (client (parameter-group aux-parameter-group) 22 | argument-variable) 23 | (declare (ignore argument-variable)) 24 | (aux-parameters-bindings client (parameters parameter-group))) 25 | -------------------------------------------------------------------------------- /Destructuring/concrete-syntax-tree-destructuring.asd: -------------------------------------------------------------------------------- 1 | (defsystem "concrete-syntax-tree-destructuring" 2 | :depends-on ("concrete-syntax-tree-lambda-list") 3 | :serial t 4 | :components ((:file "variables") 5 | (:file "generic-functions") 6 | (:file "conditions") 7 | (:file "whole-parameters") 8 | (:file "condition-generation") 9 | (:file "required-parameters") 10 | (:file "optional-parameters") 11 | (:file "rest-parameters") 12 | (:file "key-parameters") 13 | (:file "aux-parameters") 14 | (:file "lambda-list") 15 | (:file "parse-macro") 16 | (:file "db-defmacro") 17 | 18 | (:file "condition-reporters-english"))) 19 | -------------------------------------------------------------------------------- /Destructuring/condition-generation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Generic functions 6 | ;;; 7 | ;;; These are called by parse-macro, destructuring-lambda-list-bindings, etc. 8 | ;;; to produce code to report errors at runtime, i.e. when the lambda list does 9 | ;;; not match the given arguments. Methods on these functions should return 10 | ;;; forms that will signal the appropriate kind of error at runtime. 11 | ;;; These forms must not return normally. 12 | 13 | (defgeneric too-many-arguments-error (client lambda-list 14 | argument-variable macro-name)) 15 | 16 | (defgeneric too-few-arguments-error (client lambda-list 17 | argument-variable macro-name)) 18 | 19 | (defgeneric odd-keywords-error 20 | (client lambda-list argument-variable macro-name)) 21 | 22 | (defgeneric unknown-keywords-error 23 | (client lambda-list argument-variable unknown-keywords macro-name)) 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | ;;; 27 | ;;; Default methods 28 | 29 | (defmethod too-many-arguments-error (client lambda-list 30 | argument-variable macro-name) 31 | (if (cl:null macro-name) 32 | `(error "Too many elements in~%~2t~a~%to satisfy lambda list~%~2t~a" 33 | ,argument-variable ',(unparse-lambda-list client lambda-list)) 34 | `(error "Error while parsing arguments to ~a: 35 | ~2tToo many elements in~4t~a~%~2tto satisfy lambda list~%~4t~a" 36 | ',macro-name ,argument-variable 37 | ',(unparse-lambda-list client lambda-list)))) 38 | 39 | (defmethod too-few-arguments-error (client lambda-list 40 | argument-variable macro-name) 41 | (if (cl:null macro-name) 42 | `(error "Too few elements in~%~2t~a~%to satisfy lambda list~%~2t~a" 43 | ,argument-variable ',(unparse-lambda-list client lambda-list)) 44 | `(error "Error while parsing arguments to ~a: 45 | ~2tToo few elements in~4t~a~%~2tto satisfy lambda list~%~4t~a" 46 | ',macro-name ,argument-variable 47 | ',(unparse-lambda-list client lambda-list)))) 48 | 49 | (defmethod odd-keywords-error (client lambda-list 50 | argument-variable macro-name) 51 | (if (cl:null macro-name) 52 | `(error "The keyword portion of ~a has an odd length, where keywords were expected:~%~2t~a" 53 | ,argument-variable 54 | ',(unparse-lambda-list client lambda-list)) 55 | `(error "Error while parsing arguments to ~a: 56 | ~2tThe keyword portion of ~a has an odd length, where keywords were expected:~%~4t~a" 57 | ',macro-name 58 | ,argument-variable 59 | ',(unparse-lambda-list client lambda-list)))) 60 | 61 | (defmethod unknown-keywords-error (client lambda-list 62 | argument-variable unknowns macro-name) 63 | (if (cl:null macro-name) 64 | `(error "Unknown keywords ~a in~%~2t~a~%for lambda list~%~2t~a" 65 | ,unknowns ,argument-variable 66 | ',(unparse-lambda-list client lambda-list)) 67 | `(error "Error while parsing arguments to ~a: 68 | ~2tUnknown keywords ~a in~%~4t~a~%~2tfor lambda list~%~4t~a" 69 | ',macro-name ,unknowns ,argument-variable 70 | ',(unparse-lambda-list client lambda-list)))) 71 | -------------------------------------------------------------------------------- /Destructuring/condition-reporters-english.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod acclimation:report-condition 4 | ((condition null-structure-mismatch-error) stream (language acclimation:english)) 5 | (format stream "~@" 7 | (raw (whole-cst condition)) (pattern condition) 8 | (cst condition))) 9 | 10 | (defmethod acclimation:report-condition 11 | ((condition cons-structure-mismatch-error) stream (language acclimation:english)) 12 | (format stream "~@" 14 | (raw (whole-cst condition)) (pattern condition) 15 | (cst condition) 'cons-cst)) 16 | -------------------------------------------------------------------------------- /Destructuring/conditions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; Supertype for condition types related to structure mismatches 4 | ;;; during CST destructuring. 5 | (define-condition structure-mismatch-error (cst-error) 6 | ((%pattern :initarg :pattern :reader pattern) 7 | (%whole-cst :initarg :whole-cst :reader whole-cst))) 8 | 9 | ;;; This condition is signaled whenever during destructuring of a CST 10 | ;;; instance, a CST instance satisfying NULL was expected at a 11 | ;;; particular location, but something else was given. 12 | (define-condition null-structure-mismatch-error (structure-mismatch-error 13 | null-cst-required) 14 | ()) 15 | 16 | ;;; This condition is signaled whenever during destructuring of a CST 17 | ;;; instance, a CONS-CST instance was expected at a particular 18 | ;;; location, but something else was given. 19 | (define-condition cons-structure-mismatch-error (structure-mismatch-error 20 | cons-cst-required) 21 | ()) 22 | -------------------------------------------------------------------------------- /Destructuring/db-defmacro.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defun %null-or-lose (cst whole-cst pattern) 4 | (unless (null cst) 5 | (error 'null-structure-mismatch-error 6 | :pattern pattern 7 | :whole-cst whole-cst 8 | :cst cst))) 9 | 10 | (defun %first-or-lose (cst whole-cst pattern) 11 | (if (consp cst) 12 | (first cst) 13 | (error 'cons-structure-mismatch-error 14 | :pattern pattern 15 | :whole-cst whole-cst 16 | :cst cst))) 17 | 18 | (defun %rest-or-lose (cst whole-cst pattern) 19 | (if (consp cst) 20 | (rest cst) 21 | (error 'cons-structure-mismatch-error 22 | :pattern pattern 23 | :whole-cst whole-cst 24 | :cst cst))) 25 | 26 | ;;;; The purpose of the functions and the macro in this file is to 27 | ;;;; help handle source-tracking information. The main entry point in 28 | ;;;; this file is the macro DB which is very similar to the standard 29 | ;;;; Common Lisp macro DESTRUCTURING-BIND, except that DB is less 30 | ;;;; general than DESTRUCTURING-BIND in that it does not handle an 31 | ;;;; arbitrary lambda list; only a trees of variables, similar to the 32 | ;;;; destructuring done by LOOP. Also, DB does not destructure an 33 | ;;;; ordinary Common Lisp tree, and instead works on a concrete syntax 34 | ;;;; tree. Finally, DB takes an additional argument (the first one) 35 | ;;;; compared to DESTRUCTURING-BIND. That argument is a variable that 36 | ;;;; will be bound to the SOURCE slot of the CST. 37 | 38 | ;;; This function generates code for destructuring a concrete syntax 39 | ;;; tree according to a tree of variables. TREE is a tree of variable 40 | ;;; names (symbols). FORM is a form that, at runtime, computes the 41 | ;;; concrete syntax tree to be assigned to the root of TREE. This 42 | ;;; function returns a list of bindings to be used in a LET* form. 43 | ;;; These bindings destructure the root value until the leaves of the 44 | ;;; tree are reached, generating intermediate temporary variables as 45 | ;;; necessary. The destructuring code calls the functions CST:FIRST 46 | ;;; and CST:REST so that an error is signaled whenever the 47 | ;;; corresponding place in the value tree is not a CONS-CST 48 | (defun destructure-variables (tree form) 49 | (let ((bindings '()) 50 | (body-forms '())) 51 | (labels ((traverse (sub-tree sub-form) 52 | (cond ((cl:null sub-tree) 53 | (push `(%null-or-lose ,sub-form ,form ',tree) 54 | body-forms)) 55 | ((symbolp sub-tree) 56 | (push `(,sub-tree ,sub-form) bindings)) 57 | ((not (cl:consp sub-tree)) 58 | (error 'expectetree-but-found ; TODO undefined? 59 | :found sub-tree)) 60 | (t 61 | (let ((temp (gensym))) 62 | (push `(,temp ,sub-form) bindings) 63 | (traverse (cl:first sub-tree) 64 | `(%first-or-lose ,temp ,form ',tree)) 65 | (traverse (cl:rest sub-tree) 66 | `(%rest-or-lose ,temp ,form ',tree))))))) 67 | (traverse tree form)) 68 | (values (reverse bindings) (nreverse body-forms)))) 69 | 70 | (defmacro db (source-var tree form &body body) 71 | ;; We use the DUMMY-VAR hack so we can execute BODY-FORMS after 72 | ;; BINDINGS but before BODY without messing with BODY's 73 | ;; declarations. 74 | (let ((form-var (gensym)) (dummy-var (gensym))) 75 | (multiple-value-bind (bindings body-forms) 76 | (destructure-variables tree form-var) 77 | `(let* ((,form-var ,form) 78 | (,source-var (source ,form-var)) 79 | ,@bindings 80 | (,dummy-var ,@body-forms)) 81 | (declare (ignorable ,source-var ,dummy-var)) 82 | ,@body)))) 83 | -------------------------------------------------------------------------------- /Destructuring/generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;;; Generally speaking, these functions collectively take a macro 4 | ;;;; lambda list or portion thereof, and a variable, and return two 5 | ;;;; values: a list of LET* bindings that will bind the variables in 6 | ;;;; that lambda list to the value in that variable, and a list of 7 | ;;;; variables bound in the bindings that need to be declared IGNORABLE. 8 | 9 | ;;;; Each function handles a different part of the lambda list. 10 | ;;;; CLIENT is some object representing the client. ARGUMENT-VARIABLE 11 | ;;;; is a symbol that, when the resulting macro function is executed 12 | ;;;; on some compound form corresponding to a macro call, will hold 13 | ;;;; the remaining part of the arguments of that macro call yet to be 14 | ;;;; processed. If the lambda list is nontrivial, the LET* bindings 15 | ;;;; returned will repeatedly rebind this variable for the sake of 16 | ;;;; later parts of the lambda list. 17 | 18 | ;;; Given an entire lambda list, which can be a macro lambda list or 19 | ;;; a destructuring lambda list, return LET* bindings according to 20 | ;;; the parameters of the lambda list. 21 | (defgeneric destructuring-lambda-list-bindings 22 | (client lambda-list argument-variable)) 23 | 24 | ;;; Return LET* bindings corresponding to the parameters in the list 25 | ;;; of parameter groups, PARAMETER-GROUPS. 26 | (defgeneric parameter-groups-bindings 27 | (client parameter-groups argument-variable)) 28 | 29 | ;;; Return LET* bindings for a single &AUX parameter. Since &AUX 30 | ;;; parameters are independent of the macro-call arguments, there is 31 | ;;; no need for an ARGUMENT-VARIABLE. The &AUX parameter itself 32 | ;;; provides all the information required to determine the bindings. 33 | (defgeneric aux-parameter-bindings (client parameter)) 34 | 35 | ;;; Return LET* bindings for a list of &AUX parameters. 36 | (defgeneric aux-parameters-bindings (client parameters)) 37 | 38 | ;;; Return LET* bindings for a single &KEY parameter. 39 | (defgeneric key-parameter-bindings (client parameter argument-variable)) 40 | 41 | ;;; Return LET* bindings for a list of &KEY parameters. 42 | (defgeneric key-parameters-bindings (client parameters argument-variable)) 43 | 44 | ;;; Return LET* bindings for validating a &KEY parameter group. 45 | (defgeneric key-validation-bindings (client parameter-group argument-variable)) 46 | 47 | ;;; Return LET* bindings for a &REST parameter. 48 | (defgeneric rest-parameter-bindings (client parameter argument-variable)) 49 | 50 | ;;; Return LET* bindings for a single &OPTIONAL parameter. 51 | (defgeneric optional-parameter-bindings 52 | (client parameter argument-variable)) 53 | 54 | ;;; Return LET* bindings for a list of &OPTIONAL parameters. 55 | (defgeneric optional-parameters-bindings 56 | (client parameters argument-variable)) 57 | 58 | ;;; Return LET* bindings for a single required parameter. 59 | (defgeneric required-parameter-bindings 60 | (client parameter argument-variable)) 61 | 62 | ;;; Return LET* bindings for a list of required parameters. 63 | (defgeneric required-parameters-bindings 64 | (client parameters argument-variable)) 65 | 66 | ;;; Return LET* bindings for a &WHOLE parameter. 67 | (defgeneric whole-parameter-bindings (client parameter argument-variable)) 68 | -------------------------------------------------------------------------------- /Destructuring/key-parameters.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod key-parameter-bindings 4 | (client (parameter ordinary-key-parameter) argument-variable) 5 | (declare (ignore client)) 6 | (let* ((name (raw (name parameter))) 7 | (keyword (raw (keyword parameter))) 8 | (default-form-cst (form parameter)) 9 | (default-form (if (cl:null default-form-cst) 10 | nil 11 | (raw default-form-cst))) 12 | (suppliedp-cst (supplied-p parameter)) 13 | (suppliedp-dummy (gensym "SUPPLIEDP")) 14 | (default-for-getf '(cl:list nil)) 15 | (default-var (gensym "DEFAULT")) 16 | (search-var (gensym "GETF"))) 17 | `((,default-var ,default-for-getf) 18 | (,search-var (getf ,argument-variable ',keyword ,default-var)) 19 | (,suppliedp-dummy (not (eq ,search-var ,default-var))) 20 | (,name (if ,suppliedp-dummy ,search-var ,default-form)) 21 | ;; we bind suppliedp after so that it's not bound during the 22 | ;; execution of the default form. 23 | ,@(unless (cl:null suppliedp-cst) 24 | `((,(raw suppliedp-cst) ,suppliedp-dummy)))))) 25 | 26 | (defmethod key-parameter-bindings 27 | (client (parameter destructuring-key-parameter) argument-variable) 28 | (let* ((tree (name parameter)) 29 | (new-argument-variable (gensym)) 30 | (keyword (raw (keyword parameter))) 31 | (default-form-cst (form parameter)) 32 | (default-form (if (cl:null default-form-cst) 33 | nil 34 | (raw default-form-cst))) 35 | (suppliedp-cst (supplied-p parameter)) 36 | (suppliedp-dummy (gensym "SUPPLIEDP")) 37 | (default-for-getf '(cl:list nil)) 38 | (default-var (gensym "DEFAULT")) 39 | (search-var (gensym "GETF"))) 40 | (multiple-value-bind (d-l-l-bindings d-l-l-ignorables) 41 | (destructuring-lambda-list-bindings client tree new-argument-variable) 42 | (values 43 | `((,default-var ,default-for-getf) 44 | (,search-var (getf ,argument-variable ',keyword ,default-var)) 45 | (,suppliedp-dummy (not (eq ,search-var ,default-var))) 46 | (,new-argument-variable 47 | (if ,suppliedp-dummy ,search-var ,default-form)) 48 | ,@d-l-l-bindings 49 | ;; we bind suppliedp after so that it's not bound during the 50 | ;; execution of the default form or any nested defaults. 51 | ,@(unless (cl:null suppliedp-cst) 52 | `((,(raw suppliedp-cst) ,suppliedp-dummy)))) 53 | d-l-l-ignorables)))) 54 | 55 | (defmethod key-parameters-bindings 56 | (client (parameters cl:null) argument-variable) 57 | (declare (ignore client argument-variable)) 58 | nil) 59 | 60 | (defmethod key-parameters-bindings 61 | (client (parameters cl:cons) argument-variable) 62 | (loop with all-binds = nil with all-ignorables = nil 63 | for parameter in parameters 64 | do (multiple-value-bind (binds ignorables) 65 | (key-parameter-bindings client parameter argument-variable) 66 | (setf all-binds (append all-binds binds) 67 | all-ignorables (append ignorables all-ignorables))) 68 | finally (return (values all-binds all-ignorables)))) 69 | 70 | (defmethod key-validation-bindings 71 | (client (parameter-group key-parameter-group) argument-variable) 72 | (let ((glength-check (gensym "LENGTH-CHECK-DUMMY")) 73 | (length-check-form 74 | `(unless (evenp (cl:length ,argument-variable)) 75 | ,(odd-keywords-error client *current-lambda-list* 76 | argument-variable *current-macro-name*)))) 77 | (if (allow-other-keys parameter-group) 78 | (values `((,glength-check ,length-check-form)) `(,glength-check)) 79 | (let* ((unknowns (gensym "UNKNOWN-KEYWORDS")) 80 | (known-keywords 81 | (loop for parameter in (parameters parameter-group) 82 | collect (raw (keyword parameter)))) 83 | (unknowns-form 84 | `(loop with seen-allow-other-keys-p = nil 85 | with allow-other-keys = nil 86 | for (key value) on ,argument-variable by #'cl:cddr 87 | ;; :allow-other-keys is always acceptable, so we have 88 | ;; to be careful here to never include it in the 89 | ;; unknowns list. 90 | if (eq key :allow-other-keys) 91 | do (unless seen-allow-other-keys-p 92 | (setf allow-other-keys value 93 | seen-allow-other-keys-p t)) 94 | else unless (member key ',known-keywords :test #'eq) 95 | collect key into unknowns 96 | finally (unless allow-other-keys 97 | (return unknowns)))) 98 | (unknown-check (gensym "UNKNOWN-KEYWORDS-DUMMY")) 99 | (unknown-check-form 100 | `(unless (cl:null ,unknowns) 101 | ,(unknown-keywords-error client *current-lambda-list* 102 | argument-variable unknowns 103 | *current-macro-name*)))) 104 | (values `((,glength-check ,length-check-form) 105 | (,unknowns ,unknowns-form) 106 | (,unknown-check ,unknown-check-form)) 107 | `(,glength-check ,unknown-check)))))) 108 | 109 | (defmethod parameter-group-bindings 110 | (client (parameter-group key-parameter-group) 111 | argument-variable) 112 | (multiple-value-bind (validation-binds validation-ignorables) 113 | (key-validation-bindings client parameter-group argument-variable) 114 | (multiple-value-bind (main-binds main-ignorables) 115 | (key-parameters-bindings client (parameters parameter-group) 116 | argument-variable) 117 | (values (append validation-binds main-binds) 118 | (append validation-ignorables main-ignorables))))) 119 | -------------------------------------------------------------------------------- /Destructuring/lambda-list.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod parameter-groups-bindings 4 | (client (parameter-groups cl:null) argument-variable) 5 | (values `((,argument-variable 6 | (if (cl:null ,argument-variable) 7 | ,argument-variable 8 | ,(too-many-arguments-error client *current-lambda-list* 9 | argument-variable 10 | *current-macro-name*)))) 11 | (cl:list argument-variable))) 12 | 13 | (defmethod parameter-groups-bindings 14 | (client (parameter-groups cl:cons) argument-variable) 15 | (loop with all-binds = nil 16 | with all-ignorables = (cl:list argument-variable) 17 | with too-many-args-bindings 18 | = (if (some (lambda (pg) 19 | (parameter-group-varargs-p client pg)) 20 | parameter-groups) 21 | `() 22 | `((,argument-variable 23 | (if (cl:null ,argument-variable) 24 | ,argument-variable 25 | ,(too-many-arguments-error client *current-lambda-list* 26 | argument-variable 27 | *current-macro-name*))))) 28 | for parameter-group in parameter-groups 29 | do (multiple-value-bind (binds ignorables) 30 | (parameter-group-bindings client parameter-group 31 | argument-variable) 32 | (setf all-binds (append all-binds binds) 33 | all-ignorables (append ignorables all-ignorables))) 34 | finally (return 35 | (values (append all-binds too-many-args-bindings) 36 | all-ignorables)))) 37 | 38 | (defmethod destructuring-lambda-list-bindings 39 | (client (lambda-list macro-lambda-list) argument-variable) 40 | (let (;; Make sure *current-lambda-list* is bound, but allow callers to 41 | ;; make it some other lambda list if they want by not overriding. 42 | (*current-lambda-list* (if (boundp '*current-lambda-list*) 43 | *current-lambda-list* 44 | lambda-list))) 45 | (parameter-groups-bindings client (children lambda-list) 46 | argument-variable))) 47 | 48 | (defmethod destructuring-lambda-list-bindings 49 | (client (lambda-list destructuring-lambda-list) argument-variable) 50 | (let ((*current-lambda-list* lambda-list)) 51 | (parameter-groups-bindings client (children lambda-list) 52 | argument-variable))) 53 | -------------------------------------------------------------------------------- /Destructuring/optional-parameters.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod optional-parameter-bindings 4 | (client (parameter ordinary-optional-parameter) argument-variable) 5 | (declare (ignore client)) 6 | (let* ((name (raw (name parameter))) 7 | (default-form-cst (form parameter)) 8 | (default-form (if (cl:null default-form-cst) 9 | nil 10 | (raw default-form-cst))) 11 | (suppliedp-cst (supplied-p parameter)) 12 | ;; the suppliedp is not bound for the default form, so we do this. 13 | (suppliedp-dummy (gensym "SUPPLIEDP"))) 14 | `((,suppliedp-dummy (cl:consp ,argument-variable)) 15 | (,name (if ,suppliedp-dummy (cl:car ,argument-variable) ,default-form)) 16 | ,@(unless (cl:null suppliedp-cst) 17 | `((,(raw suppliedp-cst) ,suppliedp-dummy))) 18 | (,argument-variable (if ,suppliedp-dummy 19 | (cl:cdr ,argument-variable) 20 | ,argument-variable))))) 21 | 22 | (defmethod optional-parameter-bindings 23 | (client (parameter destructuring-optional-parameter) argument-variable) 24 | (let* ((tree (name parameter)) 25 | (new-argument-variable (gensym)) 26 | (default-form-cst (form parameter)) 27 | (default-form (if (cl:null default-form-cst) 28 | nil 29 | (raw default-form-cst))) 30 | (suppliedp-cst (supplied-p parameter)) 31 | ;; the suppliedp is not bound for the default form, so we do this. 32 | (suppliedp-dummy (gensym "SUPPLIEDP"))) 33 | (multiple-value-bind (d-l-l-bindings d-l-l-ignorables) 34 | (destructuring-lambda-list-bindings client tree new-argument-variable) 35 | (values 36 | `((,suppliedp-dummy (cl:consp ,argument-variable)) 37 | (,new-argument-variable 38 | (if ,suppliedp-dummy (cl:car ,argument-variable) ,default-form)) 39 | ,@d-l-l-bindings 40 | ,@(unless (cl:null suppliedp-cst) 41 | `((,(raw suppliedp-cst) ,suppliedp-dummy))) 42 | (,argument-variable (if ,suppliedp-dummy 43 | (cl:cdr ,argument-variable) 44 | ,argument-variable))) 45 | d-l-l-ignorables)))) 46 | 47 | (defmethod optional-parameters-bindings 48 | (client (parameters cl:null) argument-variable) 49 | (declare (ignore client argument-variable)) 50 | nil) 51 | 52 | (defmethod optional-parameters-bindings 53 | (client (parameters cl:cons) argument-variable) 54 | (loop with all-binds = nil with all-ignorables = nil 55 | for parameter in parameters 56 | do (multiple-value-bind (binds ignorables) 57 | (optional-parameter-bindings client parameter argument-variable) 58 | (setf all-binds (append all-binds binds) 59 | all-ignorables (append ignorables all-ignorables))) 60 | finally (return (values all-binds all-ignorables)))) 61 | 62 | (defmethod parameter-group-bindings 63 | (client (parameter-group optional-parameter-group) 64 | argument-variable) 65 | (optional-parameters-bindings client (parameters parameter-group) 66 | argument-variable)) 67 | -------------------------------------------------------------------------------- /Destructuring/parse-macro.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defun find-var (parsed-lambda-list parameter-group-type) 4 | (let* ((group (find-if (lambda (x) (typep x parameter-group-type)) 5 | (children parsed-lambda-list)))) 6 | (if (cl:null group) 7 | nil 8 | (raw (name (parameter group)))))) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;;; 12 | ;;; PARSE-MACRO 13 | ;;; 14 | ;;; According to CLtL2, except that we have added a CLIENT parameter 15 | ;;; so that it will be possible to parse implementation-specific 16 | ;;; lambda-list keywords. 17 | 18 | (defun parse-macro (client name lambda-list body &optional environment) 19 | (declare (ignore environment)) ; For now. 20 | (let* ((parsed-lambda-list (parse-macro-lambda-list client lambda-list)) 21 | (*current-lambda-list* parsed-lambda-list) 22 | (raw-name (raw name)) 23 | (*current-macro-name* raw-name) 24 | (env-var (find-var parsed-lambda-list 'environment-parameter-group)) 25 | (final-env-var (if (cl:null env-var) (gensym "ENV") env-var)) 26 | (form-var (gensym "WHOLE")) 27 | (children (children parsed-lambda-list)) 28 | (toplevel-whole-group 29 | (find-if (lambda (x) (typep x 'whole-parameter-group)) children)) 30 | (relevant-children 31 | (remove-if (lambda (x) (typep x 'environment-parameter-group)) 32 | (remove-if (lambda (x) (typep x 'whole-parameter-group)) 33 | children))) 34 | (relevant-lambda-list 35 | (make-instance 'cst:macro-lambda-list :children relevant-children)) 36 | (args-var (gensym))) 37 | (multiple-value-bind (main-bindings main-ignorables) 38 | (destructuring-lambda-list-bindings 39 | client relevant-lambda-list args-var) 40 | ;; Any toplevel &WHOLE parameter is handled separately, because it 41 | ;; starts with a different argument-variable. 42 | (multiple-value-bind (whole-bindings whole-ignorables) 43 | (if toplevel-whole-group 44 | (parameter-group-bindings client toplevel-whole-group form-var) 45 | (values nil nil)) 46 | `(lambda (,form-var ,final-env-var) 47 | (block ,raw-name 48 | (let* ((,args-var (cdr ,form-var)) 49 | ,@whole-bindings 50 | ,@main-bindings 51 | ;; We rebind the environment variable here, so that any 52 | ;; user declarations for them are scoped, properly. 53 | (,final-env-var ,final-env-var)) 54 | (declare (ignorable ,@whole-ignorables ,@main-ignorables) 55 | ;; If the lambda list does not contain &environment, 56 | ;; then we IGNORE the GENSYMed parameter to avoid 57 | ;; warnings. 58 | ;; If the lambda list does contain &environment, we do 59 | ;; not want to make it IGNORABLE because we would want 60 | ;; a warning if it is not used then. 61 | ,@(if (cl:null env-var) 62 | `((ignore ,final-env-var)) 63 | `())) 64 | ,@body))))))) 65 | -------------------------------------------------------------------------------- /Destructuring/required-parameters.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod required-parameter-bindings 4 | (client (parameter simple-variable) argument-variable) 5 | `((,(raw (name parameter)) 6 | (if (cl:consp ,argument-variable) 7 | (car ,argument-variable) 8 | ,(too-few-arguments-error client *current-lambda-list* 9 | argument-variable *current-macro-name*))) 10 | (,argument-variable (cl:cdr ,argument-variable)))) 11 | 12 | (defmethod required-parameter-bindings 13 | (client (parameter destructuring-lambda-list) argument-variable) 14 | (let ((new-argument-variable (gensym))) 15 | (multiple-value-bind (d-l-l-bindings d-l-l-ignorables) 16 | (destructuring-lambda-list-bindings 17 | client parameter new-argument-variable) 18 | (values 19 | `((,new-argument-variable 20 | (if (cl:consp ,argument-variable) 21 | (car ,argument-variable) 22 | ,(too-few-arguments-error client *current-lambda-list* 23 | argument-variable 24 | *current-macro-name*))) 25 | ,@d-l-l-bindings 26 | (,argument-variable (cl:cdr ,argument-variable))) 27 | d-l-l-ignorables)))) 28 | 29 | (defmethod required-parameters-bindings 30 | (client (parameters cl:null) argument-variable) 31 | (declare (ignore client argument-variable)) 32 | nil) 33 | 34 | (defmethod required-parameters-bindings 35 | (client (parameters cl:cons) argument-variable) 36 | (loop with all-binds = nil with all-ignorables = nil 37 | for parameter in parameters 38 | do (multiple-value-bind (binds ignorables) 39 | (required-parameter-bindings client parameter argument-variable) 40 | (setf all-binds (append all-binds binds) 41 | all-ignorables (append ignorables all-ignorables))) 42 | finally (return (values all-binds all-ignorables)))) 43 | 44 | (defmethod parameter-group-bindings 45 | (client (parameter-group destructuring-required-parameter-group) 46 | argument-variable) 47 | (required-parameters-bindings client (parameters parameter-group) 48 | argument-variable)) 49 | -------------------------------------------------------------------------------- /Destructuring/rest-parameters.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod rest-parameter-bindings 4 | (client (parameter simple-variable) argument-variable) 5 | (declare (ignore client)) 6 | `((,(raw (name parameter)) ,argument-variable))) 7 | 8 | (defmethod rest-parameter-bindings 9 | (client (parameter destructuring-lambda-list) argument-variable) 10 | (destructuring-lambda-list-bindings client parameter argument-variable)) 11 | 12 | (defmethod parameter-group-bindings 13 | (client (parameter-group destructuring-rest-parameter-group) 14 | argument-variable) 15 | (rest-parameter-bindings client (parameter parameter-group) 16 | argument-variable)) 17 | -------------------------------------------------------------------------------- /Destructuring/variables.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; This variable is used internally to maintain a reference to a lambda list 4 | ;;; that bindings are being generated for. It is used in error reporting. 5 | (defvar *current-lambda-list*) 6 | 7 | ;;; This variable is used internally to maintain a reference to the name of a 8 | ;;; macro for which a lambda list is being parsed, for error reporting. 9 | ;;; If no macro is being parsed, its value is NIL. 10 | (defvar *current-macro-name* nil) 11 | -------------------------------------------------------------------------------- /Destructuring/whole-parameters.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod whole-parameter-bindings 4 | (client (parameter simple-variable) argument-variable) 5 | (declare (ignore client)) 6 | `((,(raw (name parameter)) ,argument-variable))) 7 | 8 | (defmethod whole-parameter-bindings 9 | (client (parameter destructuring-lambda-list) argument-variable) 10 | (destructuring-lambda-list-bindings client parameter argument-variable)) 11 | 12 | (defmethod parameter-group-bindings 13 | (client (parameter-group whole-parameter-group) 14 | argument-variable) 15 | (whole-parameter-bindings client (parameter parameter-group) 16 | argument-variable)) 17 | -------------------------------------------------------------------------------- /Documentation/Makefile: -------------------------------------------------------------------------------- 1 | NAME=concrete-syntax-tree 2 | 3 | TEXFILES=$(NAME).tex $(shell ./tex-dependencies $(NAME).tex) 4 | BIBFILES=$(NAME).bib 5 | PDF_T=$(shell ./strip-dependence inputfig $(TEXFILES)) 6 | VERBATIM=$(shell ./strip-dependence verbatimtabinput $(TEXFILES)) 7 | CODEFILES=$(shell ./strip-dependence inputcode $(TEXFILES)) 8 | PDF=$(subst .pdf_t,.pdf,$(PDF_T)) 9 | 10 | all : $(NAME).pdf 11 | 12 | %.pdf: %.fig 13 | fig2dev -Lpdftex -m 0.5 $< $@ 14 | 15 | %.pdf_t: %.fig %.pdf 16 | fig2dev -Lpdftex_t -m 0.5 -p $(basename $<).pdf $< $@ 17 | 18 | %.code: %.lisp 19 | ./codify $< 20 | 21 | $(NAME).pdf: $(TEXFILES) $(PDF) $(PDF_T) $(VERBATIM) $(CODEFILES) $(BIBFILES) 22 | pdflatex $< 23 | makeindex $(NAME) 24 | bibtex $(NAME) 25 | pdflatex $< 26 | pdflatex $< 27 | 28 | view: $(NAME).pdf 29 | xpdf $< 30 | 31 | clean: 32 | rm -f *.aux *.log *~ *.pdf *.pdf *.pdf_t *.bbl *.blg 33 | 34 | spotless: clean 35 | rm -f *.ps *.dvi *.pdf *.pdf_t *.toc *.idx *.ilg *.ind *.fig.bak 36 | rm -f *.out *.cb *.cb2 37 | -------------------------------------------------------------------------------- /Documentation/chap-basic-use.tex: -------------------------------------------------------------------------------- 1 | \chapter{Basic use} 2 | 3 | In this chapter, we describe the basic functionality that \sysname{} 4 | provides for manipulating concrete syntax trees. 5 | 6 | \section{Protocol} 7 | 8 | \Defclass {cst} 9 | 10 | This class is the base class for all concrete syntax trees. 11 | 12 | \Definitarg {:raw} 13 | 14 | The value of this initialization argument is the raw \commonlisp{} 15 | expression that this concrete syntax tree represents. 16 | 17 | \Defgeneric {raw} {cst} 18 | 19 | This generic function returns the raw \commonlisp{} expression that is 20 | represented by \textit{cst} as provide by the 21 | initialization argument \texttt{:raw} when \textit{cst} was 22 | created. 23 | 24 | \Definitarg {:source} 25 | 26 | This initialization argument is accepted by all subclasses of concrete 27 | syntax trees. The value of this initialization argument is a 28 | client-specific object that indicates the origin of the source code 29 | represented by this concrete syntax tree. A value of \texttt{nil} 30 | indicates that the origin of the source code represented by this concrete 31 | syntax tree is unknown. The default value (if this initialization 32 | argument is not provided) is \texttt{nil}. 33 | 34 | \Defgeneric {source} {cst} 35 | 36 | This generic function returns the origin information of \textit{cst} 37 | as provide by the initialization argument \texttt{:source} when 38 | \textit{cst} was created. 39 | 40 | \Defgeneric {null} {cst} 41 | 42 | This generic function returns \emph{true} if and only if \textit{cst} 43 | is an instance of the class \texttt{atom-cst} that has \texttt{nil} as 44 | its raw value. Otherwise, it returns \emph{false}. 45 | 46 | \Defclass {cons-cst} 47 | 48 | This class is a subclass of the class \texttt{cst}. 49 | 50 | \Definitarg {:first} 51 | 52 | The value of this initialization argument is the concrete syntax tree 53 | that represents the \texttt{car} of the raw \commonlisp{} expression 54 | represented by this concrete syntax tree. 55 | 56 | \Definitarg {:rest} 57 | 58 | The value of this initialization argument is the concrete syntax tree 59 | that represents the \texttt{cdr} of the raw \commonlisp{} expression 60 | represented by this concrete syntax tree. 61 | 62 | \Defgeneric {first} {cons-cst} 63 | 64 | This generic function returns the concrete syntax tree that represents 65 | the \texttt{car} of the raw \commonlisp{} expression represented by 66 | \textit{cons-cst}. 67 | 68 | \Defgeneric {rest} {cons-cst} 69 | 70 | This generic function returns the concrete syntax tree that represents 71 | the \texttt{cdr} of the raw \commonlisp{} expression represented by 72 | \textit{cons-cst}. 73 | 74 | \Defgeneric {consp} {cst} 75 | 76 | This generic function returns \emph{true} if and only if \textit{cst} 77 | is an instance of the class \texttt{cons-cst}. Otherwise, it returns 78 | \emph{false}. 79 | 80 | \section{Additional API functions} 81 | 82 | \Defgeneric {second} {cons-cst} 83 | 84 | \Defgeneric {third} {cons-cst} 85 | 86 | \Defgeneric {fourth} {cons-cst} 87 | 88 | \Defgeneric {fifth} {cons-cst} 89 | 90 | \Defgeneric {sixth} {cons-cst} 91 | 92 | \Defgeneric {seventh} {cons-cst} 93 | 94 | \Defgeneric {eighth} {cons-cst} 95 | 96 | \Defgeneric {ninth} {cons-cst} 97 | 98 | \Defgeneric {tenth} {cons-cst} 99 | -------------------------------------------------------------------------------- /Documentation/chap-destructuring-lambda-lists.tex: -------------------------------------------------------------------------------- 1 | \chapter{Destructuring lambda lists} 2 | \label{chap-destructuring-lambda-lists} 3 | 4 | When applied to lambda lists, the term ``destructuring'' means to 5 | match its parameters against an argument list, and to generate a set 6 | of nested \texttt{let} bindings. A binding will bind a parameter of 7 | the lambda list to its corresponding value in the argument list, or it 8 | will bind some temporary variable. The argument list is not known at 9 | the time of the destructuring, so the \emph{form} of each binding will 10 | consist of calls to destructuring functions such as \texttt{car} and 11 | \texttt{cdr}, starting with a variable that holds the entire argument 12 | list as its value. 13 | 14 | This kind of destructuring is used at macro-expansion time when 15 | certain macros are expanded. In particular \texttt{defmacro} and 16 | \texttt{define-compiler-macro}. The result of the destructuring is a 17 | \texttt{lambda} expression for the \emph{macro function}. This lambda 18 | expression is then compiled to create the final macro function. 19 | 20 | Every function defined here wraps a \textit{body} form in some 21 | \texttt{let} bindings. These \texttt{let} bindings are determined by 22 | the parameters of a lambda list. Each function handles a different 23 | part of the lambda list. The \textit{client} parameter is some object 24 | representing the client. It is used among other things to determine 25 | which condition class to use when a a condition needs to be signaled. 26 | The \textit{argument-variable} parameter (abbreviated \textit{av} is a 27 | symbol that, when the resulting macro function is executed on some 28 | compound form corresponding to a macro call, will hold the remaining 29 | part of the arguments of that macro call yet to be processed. 30 | 31 | Some functions have an argument called \textit{tail-variable} 32 | (abbreviated \textit{tv}), which is also a symbol that is going to be 33 | used in subsequent destructuring functions for the same purpose as 34 | \textit{argument-variable}. Such a function is responsible for 35 | creating an innermost \texttt{let} form that binds the 36 | \textit{tail-variable} symbol to the part of the argument list that 37 | remains after the function has done its processing. Some functions do 38 | not need such a variable, because they do not consume any arguments, 39 | so the remaining argument list is the same as the initial one. 40 | 41 | \Defgeneric {destructure-lambda-list} {client lambda-list av tv body} 42 | 43 | Given an entire lambda list, which can be a macro lambda list or a 44 | destructuring lambda list, Wrap \textit{body} in a bunch of nested 45 | \texttt{let} bindings according to the parameters of the lambda list. 46 | 47 | \Defgeneric {destructure-aux-parameter} {client parameter body} 48 | 49 | Wrap \textit{body} in a \texttt{let} form corresponding to a single 50 | \texttt{aux} parameter. Since \texttt{aux} parameters are independent 51 | of the macro-call arguments, there is no need for an 52 | \texttt{argument-variable}. The \texttt{aux} parameter itself 53 | provides all the information required to determine the \texttt{let} 54 | binding. 55 | 56 | \Defgeneric {destructure-aux-parameters} {client parameters body} 57 | 58 | Wrap \textit{body} in nested \texttt{let} forms, each corresponding to 59 | a single \texttt{aux} parameter in the list of \texttt{aux} parameters 60 | \textit{parameters}. Since \texttt{aux} parameters are independent of 61 | the macro-call argument, there is no need for an 62 | \textit{argument-variable}. Each \texttt{aux} parameter in 63 | \textit{parameters} itself provides all the information required to 64 | determine the \texttt{let} binding. 65 | 66 | \Defgeneric {destructure-key-parameter} {client parameter av body} 67 | 68 | Wrap \textit{body} in a \texttt{let} form corresponding to a single 69 | \texttt{key} parameter. 70 | 71 | \Defgeneric {destructure-key-parameters} {client parameters av body} 72 | 73 | Wrap \textit{body} in nested \texttt{let} forms, each corresponding to 74 | a single \texttt{key} parameter in a list of such \texttt{key} 75 | parameters. Since \texttt{key} parameters do not consume any 76 | arguments, the list of arguments is the same before and after the 77 | \texttt{key} parameters have been processed. As a consequence, we do 78 | not need a \textit{tail-variable} for \texttt{key} parameters. 79 | 80 | \Defgeneric {destructure-rest-parameter} {client parameter av body} 81 | 82 | Wrap \textit{body} in a \texttt{let} form corresponding to a 83 | \texttt{rest} parameter. Since \texttt{rest} parameters do not 84 | consume any arguments, the list of arguments is the same before and 85 | after the \texttt{rest} parameter has been processed. As a 86 | consequence, we do not need a \textit{tail-variable} for \texttt{rest} 87 | parameters. 88 | 89 | \Defgeneric {destructure-optional-parameter} {client parameter av body} 90 | 91 | Wrap \textit{body} in a \texttt{let} form corresponding to a single 92 | \texttt{optional} parameter. 93 | 94 | \Defgeneric {destructure-optional-parameters} {client parameters av tv body} 95 | 96 | Wrap \textit{body} in nested \texttt{let} forms, each corresponding to 97 | a single \texttt{optional} parameter in a list of such 98 | \texttt{optional} parameters. Since every \texttt{optional} parameter 99 | \textit{does} consume an argument, this function does take a 100 | \texttt{tail-variable} argument as described above. 101 | 102 | \Defgeneric {destructure-required-parameter} {client parameter av body} 103 | 104 | Wrap \textit{body} in one or more \texttt{let} forms corresponding to 105 | a single required parameter, depending on whether the required 106 | parameter is a simple variable or a destructuring lambda list. 107 | 108 | \Defgeneric {destructure-required-parameters} {client parameters av tv body} 109 | 110 | Wrap \textit{body} in nested \texttt{let} forms, corresponding to the 111 | list of required parameters in the list of required parameters 112 | \textit{parameters}. Since every required parameter \textit{does} 113 | consume an argument, this function does take a \texttt{tail-variable} 114 | argument as described above. 115 | 116 | \Defgeneric {destructure-parameter-group} {client group av tv body} 117 | 118 | Wrap \textit{body} in nested \texttt{let} forms, corresponding to the 119 | parameters in the list of parameter groups \texttt{parameter-groups}. 120 | -------------------------------------------------------------------------------- /Documentation/chap-future.tex: -------------------------------------------------------------------------------- 1 | \chapter{Future additions to this library} 2 | \label{chap-future} 3 | -------------------------------------------------------------------------------- /Documentation/chap-intro.tex: -------------------------------------------------------------------------------- 1 | \chapter{Introduction} 2 | \pagenumbering{arabic}% 3 | 4 | \section{Purpose} 5 | 6 | \sysname{} is a library for manipulating \commonlisp{} source code 7 | enhanced with information about the origin of the source. It is 8 | intended to solve a general problem that occurs in particular in 9 | \commonlisp{} file compilers. If a file compiler compiles the file by 10 | first calling the \commonlisp{} \texttt{read} function on every 11 | top-level expression in the file, then the information about the 12 | origin of those expressions is lost. This loss of information has a 13 | serious negative impact on compiler messages, because the application 14 | programmer does not get direct information about the origin of the 15 | code that the compiler message refers to. The solution to this 16 | problem involves what is called \emph{source tracking}, which 17 | basically means that we need to keep track of this origin information 18 | from the initial file, throughout the compilation process, all the way 19 | to the executable code. 20 | 21 | One requirement for improved source tracking is that the source code 22 | must be read by an improved version of the \texttt{read} function. 23 | A typical solution would be to make \texttt{read} keep a hash table 24 | that associates the expressions being read to the location in the 25 | file. But this solution only works for freshly allocated 26 | \commonlisp{} objects. It will not work for code elements such as 27 | numbers, characters, or symbols, simply because there may be several 28 | occurrences of similar code elements in the source. 29 | 30 | The solution provided by this library is to manipulate \commonlisp{} 31 | source code in the form of a \emph{concrete syntax tree}, or CST for 32 | short. A concrete syntax tree is simply a wrapper (in the form of a 33 | standard instance) around a \commonlisp{} expression, providing the 34 | additional information required for source tracking. In order to make 35 | the manipulation of concrete syntax trees as painless as possible for 36 | client code, this library provides a set of functions that mimic the 37 | ones that would be used on raw \commonlisp{} code, such as 38 | \texttt{first}, \texttt{rest}, \texttt{consp}, \texttt{null}, etc. 39 | 40 | Since the exact nature of the origin information in a CST depends on 41 | the Common Lisp implementation and the purpose of wanting to track 42 | that origin, we do not impose a particular structure of this 43 | information. Instead, we just propagate this information as much as 44 | possible through the functions in this library that manipulate the 45 | source code in the form of CSTs. 46 | 47 | For example, we provide code utilities for canonicalizing 48 | declarations, parsing lambda lists, separating declarations and 49 | documentation strings and code bodies, checking whether a form is a 50 | proper list, etc. All these utilities manipulate the code in the form 51 | of a CST, and provide CSTs as a result of the manipulation that 52 | propagates the origin information as much as possible. 53 | 54 | In particular, we provide an "intelligent macroexpander". This 55 | function takes an original CST and the result of macroexpanding the 56 | RAW code version of that CST, and returns a new CST representing the 57 | expanded code in such a way that as much as possible of the origin 58 | information is preserved. 59 | -------------------------------------------------------------------------------- /Documentation/chap-lambda-list-parsing.tex: -------------------------------------------------------------------------------- 1 | \chapter{Lambda-list parsing} 2 | \label{chap-internals-lambda-list-parsing} 3 | 4 | For parsing lambda lists, we use a technique invented by Jay Earley in 5 | 1970 \cite{Earley:1970:ECP:362007.362035, Earley:1983:ECP:357980.358005}. 6 | -------------------------------------------------------------------------------- /Documentation/codify: -------------------------------------------------------------------------------- 1 | OUTFILE=$(echo $1 | sed -e 's/lisp/code/') 2 | echo -n "\\" >$OUTFILE 3 | echo "begin{Verbatim}[frame=single]" >>$OUTFILE 4 | expand $1 >>$OUTFILE 5 | echo "\\end{Verbatim}" >>$OUTFILE 6 | -------------------------------------------------------------------------------- /Documentation/concrete-syntax-tree.bib: -------------------------------------------------------------------------------- 1 | @book{Sedgewick:1996:IAA:227351, 2 | author = {Sedgewick, Robert and Flajolet, Philippe}, 3 | title = {An introduction to the analysis of algorithms}, 4 | year = {1996}, 5 | isbn = {0-201-40009-X}, 6 | publisher = {Addison-Wesley Longman Publishing Co., Inc.}, 7 | address = {Boston, MA, USA}, 8 | } 9 | 10 | @book{Aho:1974:DAC:578775, 11 | author = {Aho, Alfred V. and Hopcroft, John E.}, 12 | title = {The Design and Analysis of Computer Algorithms}, 13 | year = {1974}, 14 | isbn = {0201000296}, 15 | edition = {1st}, 16 | publisher = {Addison-Wesley Longman Publishing Co., Inc.}, 17 | address = {Boston, MA, USA}, 18 | } 19 | 20 | @book{McConnell:2007:AA:1374801, 21 | author = {McConnell, Jeffrey J.}, 22 | title = {Analysis of Algorithms}, 23 | year = {2007}, 24 | isbn = {9780763707828}, 25 | edition = {2}, 26 | publisher = {Jones and Bartlett Publishers, Inc.}, 27 | address = {USA}, 28 | } 29 | 30 | @inproceedings{Guibas:1978:DFB:1382432.1382565, 31 | author = {Guibas, Leo J. and Sedgewick, Robert}, 32 | title = {A Dichromatic Framework for Balanced Trees}, 33 | booktitle = {Proceedings of the 19th Annual Symposium on Foundations of Computer Science}, 34 | series = {SFCS '78}, 35 | year = {1978}, 36 | pages = {8--21}, 37 | numpages = {14}, 38 | url = {http://dx.doi.org/10.1109/SFCS.1978.3}, 39 | doi = {10.1109/SFCS.1978.3}, 40 | acmid = {1382565}, 41 | publisher = {IEEE Computer Society}, 42 | address = {Washington, DC, USA}, 43 | } 44 | 45 | @article{Sleator:1985:SBS:3828.3835, 46 | author = {Sleator, Daniel Dominic and Tarjan, Robert Endre}, 47 | title = {Self-adjusting binary search trees}, 48 | journal = {J. ACM}, 49 | issue_date = {July 1985}, 50 | volume = {32}, 51 | number = {3}, 52 | month = jul, 53 | year = {1985}, 54 | issn = {0004-5411}, 55 | pages = {652--686}, 56 | numpages = {35}, 57 | url = {http://doi.acm.org/10.1145/3828.3835}, 58 | doi = {10.1145/3828.3835}, 59 | acmid = {3835}, 60 | publisher = {ACM}, 61 | address = {New York, NY, USA}, 62 | } 63 | 64 | @incollection{Bayer:2002:BDP:944331.944346, 65 | author = {Bayer, Rudolf}, 66 | chapter = {B-trees and databases, past and future}, 67 | title = {Software pioneers}, 68 | editor = {Broy, Manfred and Denert, Ernst}, 69 | year = {2002}, 70 | isbn = {3-540-43081-4}, 71 | pages = {232--244}, 72 | numpages = {13}, 73 | url = {http://dl.acm.org/citation.cfm?id=944331.944346}, 74 | acmid = {944346}, 75 | publisher = {Springer-Verlag New York, Inc.}, 76 | address = {New York, NY, USA}, 77 | } 78 | 79 | @article{Adelson-Velskii_Landis_1962, 80 | title = {An algorithm for the organization of information}, 81 | volume = {3}, 82 | url = {http://en.scientificcommons.org/19884302}, 83 | number = {2}, 84 | journal = {Soviet Mathematics Doklady}, 85 | publisher = {JOINT PUBLICATIONS RESEARCH SERVICE WASHINGTON DC}, 86 | author = {Adelson-Velskii, G M and Landis, E M}, 87 | year={1962}, 88 | pages={263--266} 89 | } 90 | 91 | @article{Tan:1972:FIS:361573.361588, 92 | author = {Tan, K. C.}, 93 | title = {On Foster's information storage and retrieval using AVL trees}, 94 | journal = {Commun. ACM}, 95 | issue_date = {Sept. 1972}, 96 | volume = {15}, 97 | number = {9}, 98 | month = sep, 99 | year = {1972}, 100 | issn = {0001-0782}, 101 | pages = {843--}, 102 | url = {http://doi.acm.org/10.1145/361573.361588}, 103 | doi = {10.1145/361573.361588}, 104 | acmid = {361588}, 105 | publisher = {ACM}, 106 | address = {New York, NY, USA}, 107 | keywords = {binary trees, information retrieval, information storage, search trees}, 108 | } 109 | 110 | @inproceedings{Wilson:1992:UGC:645648.664824, 111 | author = {Wilson, Paul R.}, 112 | title = {Uniprocessor Garbage Collection Techniques}, 113 | booktitle = {Proceedings of the International Workshop on Memory Management}, 114 | series = {IWMM '92}, 115 | year = {1992}, 116 | isbn = {3-540-55940-X}, 117 | pages = {1--42}, 118 | numpages = {42}, 119 | url = {http://dl.acm.org/citation.cfm?id=645648.664824}, 120 | acmid = {664824}, 121 | publisher = {Springer-Verlag}, 122 | address = {London, UK, UK}, 123 | } 124 | 125 | @book{Jones:2011:GCH:2025255, 126 | author = {Jones, Richard and Hosking, Antony and Moss, Eliot}, 127 | title = {The Garbage Collection Handbook: The Art of Automatic Memory Management}, 128 | year = {2011}, 129 | isbn = {1420082795, 9781420082791}, 130 | edition = {1st}, 131 | publisher = {Chapman \& Hall/CRC}, 132 | } 133 | 134 | @article{Andersson:1999:GBT:308088.308094, 135 | author = {Andersson, Arne}, 136 | title = {General balanced trees}, 137 | journal = {J. Algorithms}, 138 | issue_date = {Jan. 1999}, 139 | volume = {30}, 140 | number = {1}, 141 | month = jan, 142 | year = {1999}, 143 | issn = {0196-6774}, 144 | pages = {1--18}, 145 | numpages = {18}, 146 | url = {http://dx.doi.org/10.1006/jagm.1998.0967}, 147 | doi = {10.1006/jagm.1998.0967}, 148 | acmid = {308094}, 149 | publisher = {Academic Press, Inc.}, 150 | address = {Duluth, MN, USA}, 151 | } 152 | 153 | @article{Stout:1986:TRO:6592.6599, 154 | author = {Stout, Q. F and Warren, B. L}, 155 | title = {Tree rebalancing in optimal time and space}, 156 | journal = {Commun. ACM}, 157 | issue_date = {Sept. 1986}, 158 | volume = {29}, 159 | number = {9}, 160 | month = sep, 161 | year = {1986}, 162 | issn = {0001-0782}, 163 | pages = {902--908}, 164 | numpages = {7}, 165 | url = {http://doi.acm.org/10.1145/6592.6599}, 166 | doi = {10.1145/6592.6599}, 167 | acmid = {6599}, 168 | publisher = {ACM}, 169 | address = {New York, NY, USA}, 170 | } 171 | 172 | @article{Waters:1992:UNC:1039991.1039996, 173 | author = {Waters, Richard C.}, 174 | title = {Using the new common Lisp pretty printer}, 175 | journal = {SIGPLAN Lisp Pointers}, 176 | issue_date = {April-June 1992}, 177 | volume = {V}, 178 | number = {2}, 179 | month = apr, 180 | year = {1992}, 181 | issn = {1045-3563}, 182 | pages = {27--34}, 183 | numpages = {8}, 184 | url = {http://doi.acm.org/10.1145/1039991.1039996}, 185 | doi = {10.1145/1039991.1039996}, 186 | acmid = {1039996}, 187 | publisher = {ACM}, 188 | address = {New York, NY, USA}, 189 | } 190 | 191 | @INPROCEEDINGS{Waters89xp:a, 192 | author = {Richard C. Waters}, 193 | title = {XP: A Common Lisp Pretty Printing System}, 194 | booktitle = {A.I. Memo 1102a, MIT Artificial Intelligence Laboratory}, 195 | year = {1989} 196 | } 197 | 198 | BibTeX | BibTeX (beta) | EndNote | ACM Ref 199 | 200 | @techreport{Huang:1990:FSM:898863, 201 | author = {Huang, Bing and Langston, Michael A.}, 202 | title = {Fast Stable Merging and Sorting in Constant Extra Space}, 203 | year = {1990}, 204 | source = {http://www.ncstrl.org:8900/ncstrl/servlet/search?formname=detail\&id=oai%3Ancstrlh%3Autk_cs%3Ancstrl.utk_cs%2F%2FUT-CS-90-106}, 205 | publisher = {University of Tennessee}, 206 | address = {Knoxville, TN, USA}, 207 | } 208 | 209 | @article{Huang:1988:PIM:42392.42403, 210 | author = {Huang, Bing-Chao and Langston, Michael A.}, 211 | title = {Practical in-place merging}, 212 | journal = {Commun. ACM}, 213 | issue_date = {March 1988}, 214 | volume = {31}, 215 | number = {3}, 216 | month = mar, 217 | year = {1988}, 218 | issn = {0001-0782}, 219 | pages = {348--352}, 220 | numpages = {5}, 221 | url = {http://doi.acm.org/10.1145/42392.42403}, 222 | doi = {10.1145/42392.42403}, 223 | acmid = {42403}, 224 | publisher = {ACM}, 225 | address = {New York, NY, USA}, 226 | } 227 | 228 | @article{Katajainen:1996:PIM:642136.642138, 229 | author = {Katajainen, Jyrki and Pasanen, Tomi and Teuhola, Jukka}, 230 | title = {Practical in-place mergesort}, 231 | journal = {Nordic J. of Computing}, 232 | issue_date = {Spring 1996}, 233 | volume = {3}, 234 | number = {1}, 235 | month = mar, 236 | year = {1996}, 237 | issn = {1236-6064}, 238 | pages = {27--40}, 239 | numpages = {14}, 240 | url = {http://dl.acm.org/citation.cfm?id=642136.642138}, 241 | acmid = {642138}, 242 | publisher = {Publishing Association Nordic Journal of Computing}, 243 | address = {Finland}, 244 | keywords = {in-place algorithms, mergesort, sorting}, 245 | } 246 | 247 | @inproceedings{Clinger:1990:RFP:93542.93557, 248 | author = {Clinger, William D.}, 249 | title = {How to read floating point numbers accurately}, 250 | booktitle = {Proceedings of the ACM SIGPLAN 1990 conference on Programming language design and implementation}, 251 | series = {PLDI '90}, 252 | year = {1990}, 253 | isbn = {0-89791-364-7}, 254 | location = {White Plains, New York, USA}, 255 | pages = {92--101}, 256 | numpages = {10}, 257 | url = {http://doi.acm.org/10.1145/93542.93557}, 258 | doi = {10.1145/93542.93557}, 259 | acmid = {93557}, 260 | publisher = {ACM}, 261 | address = {New York, NY, USA}, 262 | } 263 | 264 | @inproceedings{Burger:1996:PFN:231379.231397, 265 | author = {Burger, Robert G. and Dybvig, R. Kent}, 266 | title = {Printing floating-point numbers quickly and accurately}, 267 | booktitle = {Proceedings of the ACM SIGPLAN 1996 conference on Programming language design and implementation}, 268 | series = {PLDI '96}, 269 | year = {1996}, 270 | isbn = {0-89791-795-2}, 271 | location = {Philadelphia, Pennsylvania, USA}, 272 | pages = {108--116}, 273 | numpages = {9}, 274 | url = {http://doi.acm.org/10.1145/231379.231397}, 275 | doi = {10.1145/231379.231397}, 276 | acmid = {231397}, 277 | publisher = {ACM}, 278 | address = {New York, NY, USA}, 279 | keywords = {floating-point printing, run-time systems}, 280 | } 281 | 282 | @TECHREPORT{Gay90correctlyrounded, 283 | author = {David M. Gay}, 284 | title = {Correctly Rounded Binary-Decimal and Decimal-Binary Conversions}, 285 | institution = {Numerical Analysis Manuscript 90-10, AT\&T Bell Laboratories}, 286 | year = {1990} 287 | } 288 | 289 | @inproceedings{Doligez:1993:CGG:158511.158611, 290 | author = {Doligez, Damien and Leroy, Xavier}, 291 | title = {A concurrent, generational garbage collector for a multithreaded implementation of ML}, 292 | booktitle = {Proceedings of the 20th ACM SIGPLAN-SIGACT symposium on Principles of programming languages}, 293 | series = {POPL '93}, 294 | year = {1993}, 295 | isbn = {0-89791-560-7}, 296 | location = {Charleston, South Carolina, USA}, 297 | pages = {113--123}, 298 | numpages = {11}, 299 | url = {http://doi.acm.org/10.1145/158511.158611}, 300 | doi = {10.1145/158511.158611}, 301 | acmid = {158611}, 302 | publisher = {ACM}, 303 | address = {New York, NY, USA}, 304 | } 305 | 306 | @book{Kiczales:1991:AMP:574212, 307 | author = {Kiczales, Gregor and Rivieres, Jim Des}, 308 | title = {The Art of the Metaobject Protocol}, 309 | year = {1991}, 310 | isbn = {0262111586}, 311 | publisher = {MIT Press}, 312 | address = {Cambridge, MA, USA}, 313 | } 314 | 315 | @book{Muchnick:1998:ACD:286076, 316 | author = {Muchnick, Steven S.}, 317 | title = {Advanced compiler design and implementation}, 318 | year = {1997}, 319 | isbn = {1-55860-320-4}, 320 | publisher = {Morgan Kaufmann Publishers Inc.}, 321 | address = {San Francisco, CA, USA}, 322 | } 323 | 324 | @article{Kermany:2006:CCI:1133255.1134023, 325 | author = {Kermany, Haim and Petrank, Erez}, 326 | title = {The Compressor: Concurrent, Incremental, and Parallel Compaction}, 327 | journal = {SIGPLAN Not.}, 328 | issue_date = {June 2006}, 329 | volume = {41}, 330 | number = {6}, 331 | month = jun, 332 | year = {2006}, 333 | issn = {0362-1340}, 334 | pages = {354--363}, 335 | numpages = {10}, 336 | url = {http://doi.acm.org/10.1145/1133255.1134023}, 337 | doi = {10.1145/1133255.1134023}, 338 | acmid = {1134023}, 339 | publisher = {ACM}, 340 | address = {New York, NY, USA}, 341 | keywords = {compaction, concurrent garbage collection, garbage collection, memory management, runtime systems}, 342 | } 343 | 344 | @inproceedings{Kermany:2006:CCI:1133981.1134023, 345 | author = {Kermany, Haim and Petrank, Erez}, 346 | title = {The Compressor: Concurrent, Incremental, and Parallel Compaction}, 347 | booktitle = {Proceedings of the 2006 ACM SIGPLAN Conference on Programming Language Design and Implementation}, 348 | series = {PLDI '06}, 349 | year = {2006}, 350 | isbn = {1-59593-320-4}, 351 | location = {Ottawa, Ontario, Canada}, 352 | pages = {354--363}, 353 | numpages = {10}, 354 | url = {http://doi.acm.org/10.1145/1133981.1134023}, 355 | doi = {10.1145/1133981.1134023}, 356 | acmid = {1134023}, 357 | publisher = {ACM}, 358 | address = {New York, NY, USA}, 359 | keywords = {compaction, concurrent garbage collection, garbage collection, memory management, runtime systems}, 360 | } 361 | 362 | @article{Earley:1983:ECP:357980.358005, 363 | author = {Earley, Jay}, 364 | title = {An Efficient Context-free Parsing Algorithm}, 365 | journal = {Commun. ACM}, 366 | issue_date = {Jan. 1983}, 367 | volume = {26}, 368 | number = {1}, 369 | month = jan, 370 | year = {1983}, 371 | issn = {0001-0782}, 372 | pages = {57--61}, 373 | numpages = {5}, 374 | url = {http://doi.acm.org/10.1145/357980.358005}, 375 | doi = {10.1145/357980.358005}, 376 | acmid = {358005}, 377 | publisher = {ACM}, 378 | address = {New York, NY, USA}, 379 | keywords = {compilers, computational complexity, context-free grammar, parsing, syntax analysis}, 380 | } 381 | 382 | @article{Earley:1970:ECP:362007.362035, 383 | author = {Earley, Jay}, 384 | title = {An Efficient Context-free Parsing Algorithm}, 385 | journal = {Commun. ACM}, 386 | issue_date = {Feb 1970}, 387 | volume = {13}, 388 | number = {2}, 389 | month = feb, 390 | year = {1970}, 391 | issn = {0001-0782}, 392 | pages = {94--102}, 393 | numpages = {9}, 394 | url = {http://doi.acm.org/10.1145/362007.362035}, 395 | doi = {10.1145/362007.362035}, 396 | acmid = {362035}, 397 | publisher = {ACM}, 398 | address = {New York, NY, USA}, 399 | keywords = {compilers, computational complexity, context-free grammar, parsing, syntax analysis}, 400 | } 401 | 402 | @article{DBLP:journals/cj/AycockH02, 403 | author = {John Aycock and 404 | R. Nigel Horspool}, 405 | title = {Practical Earley Parsing}, 406 | journal = {Comput. J.}, 407 | volume = {45}, 408 | number = {6}, 409 | pages = {620--630}, 410 | year = {2002}, 411 | url = {http://dx.doi.org/10.1093/comjnl/45.6.620}, 412 | doi = {10.1093/comjnl/45.6.620}, 413 | timestamp = {Tue, 28 Jun 2011 15:16:35 +0200}, 414 | biburl = {http://dblp.uni-trier.de/rec/bib/journals/cj/AycockH02}, 415 | bibsource = {dblp computer science bibliography, http://dblp.org} 416 | } 417 | -------------------------------------------------------------------------------- /Documentation/concrete-syntax-tree.tex: -------------------------------------------------------------------------------- 1 | \documentclass[11pt]{book} 2 | \newcommand{\Comment}[1]{\begin{center}\tt #1 \end{center}} 3 | % \usepackage{doublespace} 4 | \usepackage[paperwidth=7.5in, paperheight=9.25in, 5 | inner=35mm, outer=25mm, 6 | tmargin=25mm, bmargin=30mm]{geometry} 7 | \usepackage[T1]{fontenc} 8 | \usepackage[utf8]{inputenc} 9 | \usepackage{alltt} 10 | \usepackage{moreverb} 11 | \usepackage{fancyvrb} 12 | \usepackage{epsfig} 13 | \usepackage{makeidx} 14 | \usepackage{float} 15 | \usepackage{color} 16 | \usepackage{amsthm} 17 | \usepackage{changebar} 18 | \usepackage[nottoc]{tocbibind} 19 | \usepackage{shadow} 20 | \usepackage{hyperref} 21 | \setlength\sdim{2mm} 22 | 23 | \floatplacement{figure}{!htbp} 24 | 25 | \newfloat{codefragment}{!htbp}{cod}[chapter] 26 | \floatname{codefragment}{Code fragment} 27 | 28 | \newtheorem{theorem}{Theorem}[chapter] 29 | \newtheorem{exercise}{Exercise}[chapter] 30 | \newtheorem{definition}{Definition}[chapter] 31 | 32 | \setlength{\parskip}{0.3cm} 33 | \setlength{\parindent}{0cm} 34 | 35 | \def\lispout#1{\underline{#1}} 36 | 37 | \def\mop{MOP} 38 | \def\bs{$\backslash$} 39 | \def\lispobj#1{\textsl{#1}} 40 | \def\lispobjindex#1{\lispobj{#1}\index{#1@\lispobj{#1}}} 41 | \def\syntax#1{\texttt{#1}} 42 | \def\metavar#1{\textit{#1}} 43 | \def\keyword#1{\code{\textbf{#1}}} 44 | \def\code#1{\textsf{#1}} 45 | \def\fixme#1{\footnote{\color{red}FIXME: #1}} 46 | 47 | \def\sysname{Concrete Syntax Tree} 48 | 49 | \def\inputfig#1{\input #1} 50 | \def\inputtex#1{\input #1} 51 | \def\inputal#1{\input #1} 52 | \def\inputcode#1{\input #1} 53 | 54 | \inputtex{logos.tex} 55 | \inputtex{refmacros.tex} 56 | \inputtex{spec-macros.tex} 57 | \inputtex{other-macros.tex} 58 | 59 | \newenvironment{itemize0}{ 60 | \begin{itemize} 61 | \setlength{\parskip}{0cm}% 62 | } 63 | {\end{itemize}} 64 | 65 | \newenvironment{enumerate0}{ 66 | \begin{enumerate} 67 | \setlength{\parskip}{0cm}% 68 | } 69 | {\end{enumerate}} 70 | 71 | \newenvironment{smalltt}{ 72 | \begin{alltt} 73 | \small 74 | } 75 | {\end{alltt}} 76 | 77 | %UPDATE version number when it changes. 78 | \def\majorversion{0} 79 | \def\minorversion{1} 80 | \def\bookversion{\majorversion{}.\minorversion{}} 81 | \title{{\Huge \sysname{}}\\ 82 | A library for the manipulation of\\ 83 | \commonlisp{} source code\\ 84 | enhanced with information about source origin} 85 | 86 | \author{Robert Strandh} 87 | 88 | \date{2017} 89 | 90 | \makeindex 91 | \begin{document} 92 | \pagenumbering{roman} 93 | 94 | \maketitle 95 | 96 | \newpage 97 | 98 | {\setlength{\parskip}{0cm} 99 | \tableofcontents} 100 | 101 | \inputtex{chap-intro.tex} 102 | \inputtex{part-user-manual.tex} 103 | \inputtex{part-internals.tex} 104 | 105 | \bibliography{concrete-syntax-tree}{} 106 | \bibliographystyle{alpha} 107 | 108 | \end{document} 109 | 110 | -------------------------------------------------------------------------------- /Documentation/logos.tex: -------------------------------------------------------------------------------- 1 | % Programming languages. 2 | \def\commonlisp{Common Lisp} 3 | \def\clos{CLOS} 4 | \def\closs{Common Lisp Object System} 5 | \def\lisp{Lisp} 6 | \def\hs{HyperSpec} 7 | \def\bs{$\backslash$} 8 | \def\lispobj#1{\textsl{#1}} 9 | \def\emphindex#1{\emph{#1}\index{#1}} 10 | \def\syntax#1{\texttt{#1}} 11 | \def\metavar#1{\textit{#1}} 12 | \def\code#1{\textsf{#1}} 13 | \def\FIXME#1{\footnote{\color{red}FIXME: #1}} 14 | \def\java{Java} 15 | \def\csharp{C\#} 16 | \def\javascript{JavaScript} 17 | \def\php{PHP} 18 | \def\self{Self} 19 | \def\perl{Perl} 20 | \def\python{Python} 21 | \def\ruby{Ruby} 22 | \def\smalltalk{Smalltalk} 23 | \def\simula{Simula} 24 | \def\clanguage{C} 25 | \def\cplusplus{C++} 26 | \def\fortran{Fortran} 27 | \def\pascal{Pascal} 28 | \def\algol{Algol} 29 | \def\ml{ML} 30 | \def\haskell{Haskell} 31 | \def\miranda{Miranda} 32 | \def\cobol{COBOL} 33 | \def\plone{PL/I} 34 | \def\emacs{Emacs} 35 | \def\asdf{ASDF} 36 | 37 | % Operating systems and kernels. 38 | \def\multics{Multics} 39 | \def\unix{UNIX}% The Wikipedia article says this is the way it is written. 40 | \def\gnulinux{GNU/Linux} 41 | \def\linux{Linux} 42 | \def\mach{Mach} 43 | \def\atlas{Atlas} 44 | \def\vms{VMS} 45 | \def\ibmvmcms{VM/CMS} 46 | \def\msdos{MS DOS} 47 | \def\genera{Genera} 48 | -------------------------------------------------------------------------------- /Documentation/other-macros.tex: -------------------------------------------------------------------------------- 1 | \def\sll{simply linked list} 2 | \def\Sll{Simply linked list} 3 | \def\dll{doubly linked list} 4 | \def\Dll{Doubly linked list} 5 | \def\ttt{2-3 tree} 6 | 7 | -------------------------------------------------------------------------------- /Documentation/part-internals.tex: -------------------------------------------------------------------------------- 1 | \part{Internals} 2 | \inputtex{chap-lambda-list-parsing.tex} 3 | -------------------------------------------------------------------------------- /Documentation/part-user-manual.tex: -------------------------------------------------------------------------------- 1 | \part{User manual} 2 | \inputtex{chap-basic-use.tex} 3 | \inputtex{chap-lambda-list.tex} 4 | \inputtex{chap-destructuring-lambda-lists.tex} 5 | \inputtex{chap-future.tex} 6 | -------------------------------------------------------------------------------- /Documentation/refmacros.tex: -------------------------------------------------------------------------------- 1 | \newcommand{\refalgo}[1]{algorithm~\ref{#1}}% 2 | \newcommand{\refAlgo}[1]{Algorithm~\ref{#1}}% 3 | \newcommand{\seealgo}[1]{(See \refAlgo{#1}.)}% 4 | \newcommand{\seealgox}[2]{(See \refAlgo{#1} #2.)}% 5 | 6 | \newcommand{\refpart}[1]{part~\ref{#1}}% 7 | \newcommand{\refPart}[1]{Part~\ref{#1}}% 8 | \newcommand{\seepart}[1]{(See \refPart{#1}.)}% 9 | \newcommand{\seepartx}[2]{(See \refPart{#1} #2.)}% 10 | 11 | \newcommand{\refchap}[1]{chapter~\ref{#1}}% 12 | \newcommand{\refChap}[1]{Chapter~\ref{#1}}% 13 | \newcommand{\seechap}[1]{(See \refChap{#1}.)}% 14 | \newcommand{\seechapx}[2]{(See \refChap{#1} #2.)}% 15 | 16 | \newcommand{\refapp}[1]{appendix~\ref{#1}}% 17 | \newcommand{\refApp}[1]{Appendix~\ref{#1}}% 18 | \newcommand{\seeapp}[1]{(See \refApp{#1}.)}% 19 | \newcommand{\seeappx}[2]{(See \refApp{#1} #2.)}% 20 | 21 | \newcommand{\refsec}[1]{section~\ref{#1}}% 22 | \newcommand{\refSec}[1]{Section~\ref{#1}}% 23 | \newcommand{\seesec}[1]{(See \refSec{#1}.)}% 24 | \newcommand{\seesecx}[2]{(See \refSec{#1} #2.)}% 25 | 26 | \newcommand{\reffig}[1]{figure~\ref{#1}}% 27 | \newcommand{\refFig}[1]{Figure~\ref{#1}}% 28 | \newcommand{\seefig}[1]{(See \refFig{#1}.)}% 29 | \newcommand{\seefigx}[2]{(See \refFig{#1} #2.)}% 30 | 31 | \newcommand{\refdef}[1]{definition~\ref{#1}}% 32 | \newcommand{\refDef}[1]{Definition~\ref{#1}}% 33 | \newcommand{\seedef}[1]{(See \refDef{#1}.)}% 34 | \newcommand{\seedefx}[2]{(See \refDef{#1} #2.)}% 35 | 36 | \newcommand{\reftheo}[1]{theorem~\ref{#1}}% 37 | \newcommand{\refTheo}[1]{Theorem~\ref{#1}}% 38 | \newcommand{\seetheo}[1]{(See \refTheo{#1}.)}% 39 | \newcommand{\seetheox}[2]{(See \refTheo{#1} #2.)}% 40 | 41 | \newcommand{\refexo}[1]{exercise~\ref{#1}}% 42 | \newcommand{\refExo}[1]{Exercise~\ref{#1}}% 43 | \newcommand{\seeexo}[1]{(See \refExo{#1}.)}% 44 | \newcommand{\seeexox}[2]{(See \refExo{#1} #2.)}% 45 | 46 | \newcommand{\refcode}[1]{code fragment~\ref{#1}}% 47 | \newcommand{\refCode}[1]{Code fragment~\ref{#1}}% 48 | \newcommand{\seecode}[1]{(See \refCode{#1}.)}% 49 | \newcommand{\seecodex}[2]{(See \refCode{#1} #2.)}% 50 | 51 | -------------------------------------------------------------------------------- /Documentation/spec-macros.tex: -------------------------------------------------------------------------------- 1 | % -*- Mode: LaTeX; Package: CLIM-USER -*- 2 | 3 | %% 4 | %% MACROS for CLIM Specs 5 | %% 6 | 7 | \newskip \normalparskip 8 | \normalparskip = 0pc 9 | 10 | \def\removedepth{\ifdim \prevdepth>-1000pt \vskip -\prevdepth\fi} 11 | \def\Vskip #1!{\endgraf 12 | \removedepth 13 | \ifdim \lastskip<#1 \ifdim \lastskip>0pc 14 | \removelastskip\fi 15 | \vskip#1\fi} 16 | 17 | %% 18 | %% Basic macros 19 | %% 20 | 21 | \def\curly#1{$\{${\it #1\/}$\}$} 22 | \def\star#1{#1{\rm *}} 23 | \def\form{\curly{form}} 24 | \def\place{\curly{place}} 25 | \def\paren#1{\rm({\it #1\/})} 26 | \def\brac#1{\rm[{\it #1\/}]} 27 | \def\ttbrac#1{\tt[{\it #1\/}]} 28 | \def\plus#1{$\hbox{#1}^+$} 29 | \def\placeplus{ $\{${\it place}$\}^+$} 30 | \def\lparen{{\rm (}} 31 | \def\rparen{{\rm )}} 32 | 33 | \def\optional{{\tt\&optional\ }} 34 | \def\rest{{\tt\&rest\ }} 35 | \def\key{{\tt\&key\ }} 36 | \def\allow{{\tt\&allow-other-keys\ }} 37 | \def\body{{\tt\&body\ }} 38 | 39 | \def\arg#1{{\it #1}} 40 | 41 | %% When you supply a default value for optional or keyword arguments, 42 | %% use this idiom: \key (filled \cl{t}) 43 | %% \newcommand {\cl} [1] {{\tt #1}} 44 | 45 | %% This allows hyphenation of CL symbols at the hyphens that exist in 46 | %% the symbol name, but noplace else, e.g., \cl{standard\-region\-union}. 47 | %% The reason we don't use this is that the backslashes in the symbol 48 | %% names make Tags Search next to useless. 49 | %% \def\cl#1{{\def\-{\discretionary{-}{}{-}}\tt #1}} 50 | 51 | %% Spiffier version that hyphenates only at hyphens, but makes hyphens 52 | %% be active characters, so we don't break Tags Search. Thanks to 53 | %% Stephen Gildea for providing this. 54 | {\catcode`\-=\active 55 | \gdef\cl{\bgroup 56 | \catcode`\-=\active \def-{{\tt \char`\-}\penalty\exhyphenpenalty}% 57 | \@cl}} 58 | \def\@cl#1{\texttt{#1}\egroup} 59 | 60 | %% Use \concept when you are introducing a term for the first time, and 61 | %% want it in the index. Use \term after that. 62 | \newcommand {\concept} [1] {{\sl #1}\index{#1}} 63 | \newcommand {\term} [1] {{\sl #1}} 64 | 65 | %% 66 | %% Miscellaneous 67 | %% 68 | 69 | \long\def\comment #1 {} 70 | 71 | \long\def\keepout #1 {} 72 | 73 | \long\def\Issue #1 #2 {{\bf Major issue: } {\sl #2 ---~#1}} 74 | \long\def\issue #1 #2 {{\bf Minor issue: } {\sl #2 ---~#1}} 75 | 76 | %% 77 | %% Definition types 78 | %% 79 | 80 | \def\outdent#1{\noindent\hbox to 0pc{\hskip -1.5pc #1\hss}\ignorespaces} 81 | 82 | \newcommand {\Dodocf} [3] {\outdent{$\Rightarrow$}{\tt #1 {\it #2} \hfill\mbox{\brac{\it #3\/}}} 83 | \index{{\tt #1} #3} 84 | \Vskip\normalparskip!} 85 | \newcommand {\Dodocv} [2] {\outdent{$\Rightarrow$}{\tt #1 \hfill\mbox{\brac{\it #2\/}}} 86 | \index{{\tt #1} #2} 87 | \Vskip\normalparskip!} 88 | 89 | %% Use these when you want to leave some vertical whitespace afterwards 90 | \def\Defmacro #1 #2 {\Dodocf {#1} {#2} {Macro}} 91 | \def\Defun #1 #2 {\Dodocf {#1} {#2} {Function}} 92 | \def\Defgeneric #1 #2 {\Dodocf {#1} {#2} {Generic~Function}} 93 | \def\Defmethod #1 #2 {\Dodocf {#1} {#2} {Method}} 94 | \def\Defaftermethod #1 #2 {\Dodocf {#1} {#2} {:After~Method}} 95 | \def\Defaroundmethod #1 #2 {\Dodocf {#1} {#2} {:Around~Method}} 96 | \def\Defvar #1 {\Dodocv {#1} {Variable}} 97 | \def\Defconst #1 {\Dodocv {#1} {Constant}} 98 | \def\Defprotoclass #1 {\Dodocv {#1} {Protocol~Class}} 99 | \def\Defpredicate #1 #2 {\Dodocf {#1} {#2} {Protocol~Predicate}} 100 | \def\Defclass #1 {\Dodocv {#1} {Class}} 101 | \def\Definitarg #1 {\Dodocv {#1} {Initarg}} 102 | \def\Deftype #1 {\Dodocv {#1} {Type}} 103 | \def\Defoption #1 {\Dodocv {#1} {Option}} 104 | \def\Defptype #1 #2 {\Dodocf {#1} {#2} {Presentation~Type}} 105 | \def\DefptypeAbbrev #1 #2 {\Dodocf {#1} {#2} {Presentation~Type~Abbreviation}} 106 | \def\Defcondition #1 {\Dodocv {#1} {Condition}} 107 | \def\Deferror #1 {\Dodocv {#1} {Error Condition}} 108 | \def\Defrestart #1 {\Dodocv {#1} {Restart}} 109 | 110 | \newcommand {\dodocf} [3] {\outdent{$\Rightarrow$}{\tt #1 {\it #2} \hfill\mbox{\brac{\it #3\/}}} 111 | \index{{\tt #1} #3} 112 | \linebreak} 113 | \newcommand {\dodocv} [2] {\outdent{$\Rightarrow$}{\tt #1 \hfill\mbox{\brac{\it #2\/}}} 114 | \index{{\tt #1} #2} 115 | \linebreak} 116 | 117 | %% Use these when you don't want to leave any vertical whitespace afterwards 118 | \def\defmacro #1 #2 {\dodocf {#1} {#2} {Macro}} 119 | \def\defun #1 #2 {\dodocf {#1} {#2} {Function}} 120 | \def\defgeneric #1 #2 {\dodocf {#1} {#2} {Generic~Function}} 121 | \def\defmethod #1 #2 {\dodocf {#1} {#2} {Method}} 122 | \def\defvar #1 {\dodocv {#1} {Variable}} 123 | \def\defconst #1 {\dodocv {#1} {Constant}} 124 | \def\defprotoclass #1 {\dodocv {#1} {Protocol~Class}} 125 | \def\defpredicate #1 #2 {\dodocf {#1} {#2} {Protocol~Predicate}} 126 | \def\defclass #1 {\dodocv {#1} {Class}} 127 | \def\definitarg #1 {\dodocv {#1} {Initarg}} 128 | \def\defoption #1 {\dodocv {#1} {Option}} 129 | 130 | \def\Defcommandtable #1 {\Dodocv {#1} {Command~Table}} 131 | \def\Defframe #1 {\Dodocv {#1} {Application~Frame}} 132 | 133 | \def\Defgadget #1 {\Dodocv {#1} {Abstract~Gadget}} 134 | \def\defgadget #1 {\dodocv {#1} {Abstract~Gadget}} 135 | 136 | \def\Defspane #1 {\Dodocv {#1} {Service~Pane}} 137 | \def\defspane #1 {\dodocv {#1} {Service~Pane}} 138 | \def\Deflpane #1 {\Dodocv {#1} {Layout~Pane}} 139 | \def\deflpane #1 {\dodocv {#1} {Layout~Pane}} 140 | 141 | \def\Callback #1 #2 {\Dodocf {#1} {#2} {Callback~Generic~Function}} 142 | \def\callback #1 #2 {\dodocf {#1} {#2} {Callback~Generic~Function}} 143 | 144 | %% 145 | %% Canned phrases. 146 | %% 147 | 148 | \def\IfYouWantClass #1 #2 #3 {If you want to create a new class that behaves 149 | like #1 #2, it should be a subclass of \cl{#3}. All instantiable subclasses of 150 | \cl{#3} must obey the #2 protocol.\ } 151 | 152 | \def\AbstractClass{This class is an abstract class, intended only to be 153 | subclassed, not instantiated.\ } 154 | 155 | \def\Mutable{Members of this class are mutable.\ } 156 | 157 | \def\Immutable{Members of this class are immutable.\ } 158 | 159 | \def\UncapturedInputs{This function does not capture any of its mutable inputs.\ } 160 | 161 | \def\MayCaptureInputs{This function is permitted to capture its mutable inputs; the 162 | consequences of modifying those objects are unspecified.\ } 163 | 164 | \def\FreshOutputs{This function returns fresh objects that may be modified.\ } 165 | 166 | \def\ReadOnly{This function returns objects that reveal CLIM's internal state; 167 | do not modify those objects.\ } 168 | 169 | \def\ReadWrite{This function returns objects that reveal CLIM's internal state; 170 | these objects may be modified.\ } 171 | 172 | \def\NotInRelease2{{\sl This is not fully supported in Release 2.\ }} 173 | -------------------------------------------------------------------------------- /Documentation/strip-dependence: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | CHAINE=$1 3 | MOTIF="^\\\\$CHAINE\{.*\}" 4 | shift 5 | for i in $* 6 | do 7 | egrep $MOTIF $i \ 8 | | sed "s/^\\\\$CHAINE{\(.*\)}/\1/" \ 9 | | tr ['\n'] [' '] 10 | done 11 | 12 | 13 | -------------------------------------------------------------------------------- /Documentation/tex-dependencies: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | #set -x 4 | TEXFILES=$(./strip-dependence inputtex $1) 5 | echo -n $TEXFILES 6 | for i in $TEXFILES 7 | do 8 | echo -n " " $(./tex-dependencies $i) 9 | done 10 | echo 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2017 - 2018 2 | ;;;; 3 | ;;;; Robert Strandh (robert.strandh@gmail.com) 4 | ;;;; 5 | ;;;; All rights reserved. 6 | ;;;; 7 | ;;;; Redistribution and use in source and binary forms, with or 8 | ;;;; without modification, are permitted provided that the following 9 | ;;;; conditions are met: 10 | ;;;; 11 | ;;;; 1. Redistributions of source code must retain the above copyright 12 | ;;;; notice, this list of conditions and the following disclaimer. 13 | ;;;; 2. Redistributions in binary form must reproduce the above 14 | ;;;; copyright notice, this list of conditions and the following 15 | ;;;; disclaimer in the documentation and/or other materials 16 | ;;;; provided with the distribution. 17 | ;;;; 18 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 19 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 20 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 21 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 23 | ;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 24 | ;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 25 | ;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 27 | ;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | ;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 29 | ;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | ;;;; POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Lambda-list/Test/compare-parse-trees.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-lambda-list-test) 2 | 3 | (defgeneric compare-parse-trees (tree1 tree2)) 4 | 5 | (defmethod compare-parse-trees (tree1 tree2) 6 | (declare (ignore tree1 tree2)) 7 | nil) 8 | 9 | (defun compare-lists (list1 list2) 10 | (and (= (length list1) (length list2)) 11 | (every #'compare-parse-trees list1 list2))) 12 | 13 | (defmethod compare-parse-trees 14 | ((tree1 cst::lambda-list-type) (tree2 cst::lambda-list-type)) 15 | (and (eq (class-of tree1) (class-of tree2)) 16 | (compare-lists (cst::children tree1) (cst::children tree2)))) 17 | 18 | (defmethod compare-parse-trees 19 | ((tree1 cst::implicit-parameter-group) 20 | (tree2 cst::implicit-parameter-group)) 21 | (and (eq (class-of tree1) (class-of tree2)) 22 | (compare-lists (cst::parameters tree1) (cst::parameters tree2)))) 23 | 24 | (defmethod compare-parse-trees 25 | ((tree1 cst::explicit-parameter-group) 26 | (tree2 cst::explicit-parameter-group)) 27 | (and (eq (class-of tree1) (class-of tree2)) 28 | (eq (cst:raw (cst::name (cst::keyword tree1))) 29 | (cst:raw (cst::name (cst::keyword tree2)))) 30 | (compare-lists (cst::parameters tree1) (cst::parameters tree2)))) 31 | 32 | (defmethod compare-parse-trees 33 | ((tree1 cst::singleton-parameter-group) 34 | (tree2 cst::singleton-parameter-group)) 35 | (and (eq (class-of tree1) (class-of tree2)) 36 | (eq (cst:raw (cst::name (cst::keyword tree1))) 37 | (cst:raw (cst::name (cst::keyword tree2)))) 38 | (compare-parse-trees (cst::parameter tree1) (cst::parameter tree2)))) 39 | 40 | (defmethod compare-parse-trees 41 | ((tree1 cst::simple-variable) 42 | (tree2 cst::simple-variable)) 43 | (eq (cst:raw (cst::name tree1)) (cst:raw (cst::name tree2)))) 44 | 45 | (defmethod compare-parse-trees 46 | ((tree1 cst::ordinary-optional-parameter) 47 | (tree2 cst::ordinary-optional-parameter)) 48 | (and (eq (cst:raw (cst::name tree1)) 49 | (cst:raw (cst::name tree2))) 50 | (or (equal (cst::form tree1) (cst::form tree2)) 51 | (equal (cst:raw (cst::form tree1)) (cst:raw (cst::form tree2)))) 52 | (or (equal (cst::supplied-p tree1) (cst::supplied-p tree2)) 53 | (eq (cst:raw (cst::supplied-p tree1)) 54 | (cst:raw (cst::supplied-p tree2)))))) 55 | 56 | (defmethod compare-parse-trees 57 | ((tree1 cst::generic-function-optional-parameter) 58 | (tree2 cst::generic-function-optional-parameter)) 59 | (eq (cst:raw (cst::name tree1)) 60 | (cst:raw (cst::name tree2)))) 61 | 62 | (defmethod compare-parse-trees 63 | ((tree1 cst::ordinary-key-parameter) 64 | (tree2 cst::ordinary-key-parameter)) 65 | (and (eq (cst:raw (cst::name tree1)) 66 | (cst:raw (cst::name tree2))) 67 | (eq (cst:raw (cst::keyword tree1)) 68 | (cst:raw (cst::keyword tree2))) 69 | (or (eq (cst::form tree1) (cst::form tree2)) 70 | (equal (cst:raw (cst::form tree1)) 71 | (cst:raw (cst::form tree2)))) 72 | (or (eq (cst::supplied-p tree1) 73 | (cst::supplied-p tree2)) 74 | (eq (cst:raw (cst::supplied-p tree1)) 75 | (cst:raw (cst::supplied-p tree2)))))) 76 | 77 | (defmethod compare-parse-trees 78 | ((tree1 cst::generic-function-key-parameter) 79 | (tree2 cst::generic-function-key-parameter)) 80 | (and (eq (cst:raw (cst::name tree1)) 81 | (cst:raw (cst::name tree2))) 82 | (eq (cst:raw (cst::keyword tree1)) 83 | (cst:raw (cst::keyword tree2))))) 84 | 85 | (defmethod compare-parse-trees 86 | ((tree1 cst::aux-parameter) 87 | (tree2 cst::aux-parameter)) 88 | (and (eq (cst:raw (cst::name tree1)) 89 | (cst:raw (cst::name tree2))) 90 | (equal (cst:raw (cst::form tree1)) 91 | (cst:raw (cst::form tree2))))) 92 | 93 | (defmethod compare-parse-trees 94 | ((tree1 cst::specialized-required-parameter) 95 | (tree2 cst::specialized-required-parameter)) 96 | (and (eq (cst:raw (cst::name tree1)) 97 | (cst:raw (cst::name tree2))) 98 | (equal (cst:raw (cst::specializer tree1)) 99 | (cst:raw (cst::specializer tree2))))) 100 | -------------------------------------------------------------------------------- /Lambda-list/Test/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:concrete-syntax-tree-lambda-list-test 2 | (:use 3 | #:common-lisp) 4 | 5 | (:import-from #:fiveam 6 | #:def-suite 7 | #:in-suite 8 | #:test 9 | #:is 10 | #:is-true) 11 | 12 | (:export 13 | #:run-tests)) 14 | 15 | (cl:in-package #:concrete-syntax-tree-lambda-list-test) 16 | 17 | (def-suite :concrete-syntax-tree-lambda-list) 18 | 19 | (defun run-tests () 20 | (fiveam:run! :concrete-syntax-tree-lambda-list)) 21 | -------------------------------------------------------------------------------- /Lambda-list/Test/random-lambda-list.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-lambda-list-test) 2 | 3 | (defparameter *variables* 4 | '(a b c d e f g h i j k l m n o p q r s u v w x y z)) 5 | 6 | (defun random-variable () 7 | (elt *variables* (random (length *variables*)))) 8 | 9 | (defun random-form () 10 | (list (random-variable) (random-variable))) 11 | 12 | (defun random-ordinary-required-parameter-group () 13 | (loop repeat (random 5) 14 | collect (random-variable))) 15 | 16 | (defun random-ordinary-optional-parameter () 17 | (let ((x (random 1d0))) 18 | (cond ((< x 0.25d0) 19 | (random-variable)) 20 | ((< x 0.5d0) 21 | (list (random-variable))) 22 | ((< x 0.75d0) 23 | (list (random-variable) (random-form))) 24 | (t 25 | (list (random-variable) (random-form) (random-variable)))))) 26 | 27 | (defun random-ordinary-optional-parameter-group () 28 | (let ((x (random 1d0))) 29 | (if (< x 0.25d0) 30 | '() 31 | (cons '&optional 32 | (loop repeat (random 5) 33 | collect (random-ordinary-optional-parameter)))))) 34 | 35 | (defun random-ordinary-rest-parameter-group () 36 | (let ((x (random 1d0))) 37 | (if (< x 0.25d0) 38 | '() 39 | (list '&rest (random-variable))))) 40 | 41 | (defun random-key-variable () 42 | (let ((x (random 1d0))) 43 | (if (< x 0.5d0) 44 | (random-variable) 45 | (list (random-variable) (random-variable))))) 46 | 47 | (defun random-ordinary-key-parameter () 48 | (let ((x (random 1d0))) 49 | (cond ((< x 0.25d0) 50 | (random-variable)) 51 | ((< x 0.5d0) 52 | (list (random-key-variable))) 53 | ((< x 0.75d0) 54 | (list (random-key-variable) (random-form))) 55 | (t 56 | (list (random-key-variable) (random-form) (random-variable)))))) 57 | 58 | (defun random-ordinary-key-parameter-group () 59 | (let ((x (random 1d0)) 60 | (y (random 1d0))) 61 | (if (< x 0.25d0) 62 | '() 63 | (cons '&key 64 | (append (loop repeat (random 5) 65 | collect (random-ordinary-key-parameter)) 66 | (if (< y 0.5d0) 67 | '() 68 | '(&allow-other-keys))))))) 69 | 70 | (defun random-aux-parameter () 71 | (let ((x (random 1d0))) 72 | (cond ((< x 0.33d0) 73 | (random-variable)) 74 | ((< x 0.66d0) 75 | (list (random-variable))) 76 | (t 77 | (list (random-variable) (random-form)))))) 78 | 79 | (defun random-aux-parameter-group () 80 | (let ((x (random 1d0))) 81 | (if (< x 0.25d0) 82 | '() 83 | (cons '&aux 84 | (loop repeat (random 5) 85 | collect (random-aux-parameter)))))) 86 | 87 | (defun random-ordinary-lambda-list () 88 | (append (random-ordinary-required-parameter-group) 89 | (random-ordinary-optional-parameter-group) 90 | (random-ordinary-rest-parameter-group) 91 | (random-ordinary-key-parameter-group) 92 | (random-aux-parameter-group))) 93 | 94 | (defun random-generic-function-optional-parameter () 95 | (let ((x (random 1d0))) 96 | (cond ((< x 0.5d0) 97 | (random-variable)) 98 | (t 99 | (list (random-variable)))))) 100 | 101 | (defun random-generic-function-optional-parameter-group () 102 | (let ((x (random 1d0))) 103 | (if (< x 0.25d0) 104 | '() 105 | (cons '&optional 106 | (loop repeat (random 5) 107 | collect (random-generic-function-optional-parameter)))))) 108 | 109 | (defun random-generic-function-key-parameter () 110 | (let ((x (random 1d0))) 111 | (cond ((< x 0.5d0) 112 | (random-variable)) 113 | (t 114 | (list (random-key-variable)))))) 115 | 116 | (defun random-generic-function-key-parameter-group () 117 | (let ((x (random 1d0)) 118 | (y (random 1d0))) 119 | (if (< x 0.25d0) 120 | '() 121 | (cons '&key 122 | (append (loop repeat (random 5) 123 | collect (random-generic-function-key-parameter)) 124 | (if (< y 0.5d0) 125 | '() 126 | '(&allow-other-keys))))))) 127 | 128 | (defun random-generic-function-lambda-list () 129 | (append (random-ordinary-required-parameter-group) 130 | (random-generic-function-optional-parameter-group) 131 | (random-ordinary-rest-parameter-group) 132 | (random-generic-function-key-parameter-group))) 133 | 134 | (defun random-specialized-required-parameter () 135 | (let ((x (random 1d0))) 136 | (cond ((< x 0.25d0) 137 | (random-variable)) 138 | ((< x 0.5d0) 139 | (list (random-variable))) 140 | ((< x 0.75d0) 141 | (list (random-variable) (random-variable))) 142 | (t 143 | (list (random-variable) 144 | (list 'eql (random-form))))))) 145 | 146 | (defun random-specialized-required-parameter-group () 147 | (loop repeat (random 5) 148 | collect (random-specialized-required-parameter))) 149 | 150 | (defun random-specialized-lambda-list () 151 | (append (random-specialized-required-parameter-group) 152 | (random-ordinary-optional-parameter-group) 153 | (random-ordinary-rest-parameter-group) 154 | (random-ordinary-key-parameter-group) 155 | (random-aux-parameter-group))) 156 | 157 | (defun random-environment-parameter-group (probability) 158 | (let ((x (random 1d0))) 159 | (if (< x probability) 160 | (list '&environment (random-variable)) 161 | '()))) 162 | 163 | (defun random-defsetf-lambda-list () 164 | (append (random-ordinary-required-parameter-group) 165 | (random-ordinary-optional-parameter-group) 166 | (random-ordinary-rest-parameter-group) 167 | (random-ordinary-key-parameter-group) 168 | (random-environment-parameter-group 0.5d0))) 169 | 170 | (defun random-define-modify-macro-lambda-list () 171 | (append (random-ordinary-required-parameter-group) 172 | (random-ordinary-optional-parameter-group) 173 | (random-ordinary-rest-parameter-group))) 174 | 175 | (defun random-whole-parameter-group () 176 | (let ((x (random 1d0))) 177 | (if (< x 0.25d0) 178 | '() 179 | (list '&whole (random-variable))))) 180 | 181 | (defun random-define-method-combination-lambda-list () 182 | (append (random-whole-parameter-group) 183 | (random-ordinary-required-parameter-group) 184 | (random-ordinary-optional-parameter-group) 185 | (random-ordinary-rest-parameter-group) 186 | (random-ordinary-key-parameter-group) 187 | (random-aux-parameter-group))) 188 | 189 | (defun random-destructuring-parameter () 190 | (let ((x (random 1d0))) 191 | (if (< x 0.9d0) 192 | (random-variable) 193 | (random-destructuring-lambda-list)))) 194 | 195 | (defun random-destructuring-required-parameter-group () 196 | (loop repeat (random 5) 197 | collect (random-destructuring-parameter))) 198 | 199 | (defun random-destructuring-rest-parameter-group () 200 | (let ((x (random 1d0))) 201 | (if (< x 0.5d0) 202 | '() 203 | (list (if (< x 0.75) '&rest '&body) 204 | (random-destructuring-parameter))))) 205 | 206 | (defun random-destructuring-lambda-list () 207 | (append (random-whole-parameter-group) 208 | (random-destructuring-required-parameter-group) 209 | (random-ordinary-optional-parameter-group) 210 | (random-destructuring-rest-parameter-group) 211 | (random-ordinary-key-parameter-group) 212 | (random-aux-parameter-group))) 213 | 214 | (defun random-macro-lambda-list () 215 | (let ((seen-environment-p nil)) 216 | (flet ((random-environment () 217 | (let ((env (random-environment-parameter-group 0.1))) 218 | (if (or (null env) seen-environment-p) 219 | '() 220 | (progn (setf seen-environment-p t) env))))) 221 | (append (random-whole-parameter-group) 222 | (random-environment) 223 | (let ((temp (random-destructuring-required-parameter-group))) 224 | (if (null temp) 225 | (list (random-variable)) 226 | temp)) 227 | (random-environment) 228 | (random-ordinary-optional-parameter-group) 229 | (random-environment) 230 | (random-destructuring-rest-parameter-group) 231 | (random-environment) 232 | (random-ordinary-key-parameter-group) 233 | (random-environment) 234 | (random-aux-parameter-group) 235 | (random-environment))))) 236 | -------------------------------------------------------------------------------- /Lambda-list/Test/test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-lambda-list-test) 2 | 3 | (in-suite :concrete-syntax-tree-lambda-list) 4 | 5 | (defun assert-success (parser) 6 | (let ((item (cst::find-final-item parser))) 7 | (is-true (not (null item))) 8 | (car (cst::parse-trees item)))) 9 | 10 | (defun test-ordinary (lambda-list) 11 | (let* ((p (make-instance 'cst:parser 12 | :grammar cst:*ordinary-lambda-list-grammar* 13 | :input (cst:cst-from-expression lambda-list) 14 | :lambda-list (make-instance 'cst:ordinary-lambda-list) 15 | :client nil))) 16 | (cst:parse p) 17 | (let ((result (assert-success p))) 18 | (compare-parse-trees result (parse-ordinary-lambda-list lambda-list))))) 19 | 20 | (defun test-generic-function (lambda-list) 21 | (let* ((p (make-instance 'cst:parser 22 | :grammar cst:*generic-function-lambda-list-grammar* 23 | :input (cst:cst-from-expression lambda-list) 24 | :lambda-list 25 | (make-instance 'cst:generic-function-lambda-list) 26 | :client nil))) 27 | (cst:parse p) 28 | (let ((result (assert-success p))) 29 | (compare-parse-trees 30 | result (parse-generic-function-lambda-list lambda-list))))) 31 | 32 | (defun test-specialized (lambda-list) 33 | (let* ((p (make-instance 'cst:parser 34 | :grammar cst:*specialized-lambda-list-grammar* 35 | :input (cst:cst-from-expression lambda-list) 36 | :lambda-list 37 | (make-instance 'cst:specialized-lambda-list) 38 | :client nil))) 39 | (cst:parse p) 40 | (let ((result (assert-success p))) 41 | (compare-parse-trees 42 | result (parse-specialized-lambda-list lambda-list))))) 43 | 44 | (defun test-defsetf (lambda-list) 45 | (let* ((p (make-instance 'cst:parser 46 | :grammar cst:*defsetf-lambda-list-grammar* 47 | :input (cst:cst-from-expression lambda-list) 48 | :lambda-list 49 | (make-instance 'cst:defsetf-lambda-list) 50 | :client nil))) 51 | (cst:parse p) 52 | (let ((result (assert-success p))) 53 | (compare-parse-trees 54 | result (parse-defsetf-lambda-list lambda-list))))) 55 | 56 | (defun test-define-modify-macro (lambda-list) 57 | (let* ((p (make-instance 'cst:parser 58 | :grammar cst:*define-modify-macro-lambda-list-grammar* 59 | :input (cst:cst-from-expression lambda-list) 60 | :lambda-list 61 | (make-instance 'cst:define-modify-macro-lambda-list) 62 | :client nil))) 63 | (cst:parse p) 64 | (let ((result (assert-success p))) 65 | (compare-parse-trees 66 | result (parse-define-modify-macro-lambda-list lambda-list))))) 67 | 68 | (defun test-define-method-combination (lambda-list) 69 | (let* ((p (make-instance 'cst:parser 70 | :grammar cst:*define-method-combination-lambda-list-grammar* 71 | :input (cst:cst-from-expression lambda-list) 72 | :lambda-list 73 | (make-instance 'cst:define-method-combination-lambda-list) 74 | :client nil))) 75 | (cst:parse p) 76 | (let ((result (assert-success p))) 77 | (compare-parse-trees 78 | result (parse-define-method-combination-lambda-list lambda-list))))) 79 | 80 | (defun test-destructuring (lambda-list) 81 | (let* ((p (make-instance 'cst:parser 82 | :grammar cst:*destructuring-lambda-list-grammar* 83 | :input (cst:cst-from-expression lambda-list) 84 | :lambda-list 85 | (make-instance 'cst:destructuring-lambda-list) 86 | :client nil))) 87 | (cst:parse p) 88 | (let ((result (assert-success p))) 89 | (compare-parse-trees 90 | result (parse-destructuring-lambda-list lambda-list))))) 91 | 92 | (defun test-macro (lambda-list) 93 | (let* ((p (make-instance 'cst:parser 94 | :grammar cst:*macro-lambda-list-grammar* 95 | :input (cst:cst-from-expression lambda-list) 96 | :lambda-list 97 | (make-instance 'cst:macro-lambda-list) 98 | :client nil))) 99 | (cst:parse p) 100 | (let ((result (assert-success p))) 101 | (compare-parse-trees 102 | result (parse-macro-lambda-list lambda-list))))) 103 | 104 | (macrolet ((define (name) 105 | (let ((test-name (intern (format nil "~A-LAMBDA-LIST" name) *package*)) 106 | (checker (intern (format nil "TEST-~A" name) *package*)) 107 | (generator (intern (format nil "RANDOM-~A-LAMBDA-LIST" name) 108 | *package*))) 109 | `(test ,test-name 110 | (let ((fiveam:*test-dribble* nil)) ; too much output otherwise 111 | (loop repeat 10000 112 | do (assert (,checker (,generator))))))))) 113 | 114 | 115 | (define #:ordinary) 116 | (define #:generic-function) 117 | (define #:specialized) 118 | (define #:defsetf) 119 | (define #:define-modify-macro) 120 | (define #:define-method-combination) 121 | (define #:destructuring) 122 | (define #:macro)) 123 | -------------------------------------------------------------------------------- /Lambda-list/Test/unparse.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-lambda-list-test) 2 | 3 | (defgeneric unparse (tree)) 4 | 5 | (defmethod unparse ((tree cst::lambda-list-type)) 6 | (reduce #'append (mapcar #'unparse (cst::children tree)))) 7 | 8 | (defmethod unparse ((tree cst::parameter-group)) 9 | (mapcar #'unparse (cst::parameters tree))) 10 | 11 | (defmethod unparse ((tree cst::lambda-list-keyword)) 12 | (cst::name tree)) 13 | 14 | (defmethod unparse ((tree cst::simple-variable)) 15 | (cst::name tree)) 16 | 17 | (defmethod unparse ((tree cst::ordinary-optional-parameter)) 18 | (list (cst::name tree) 19 | (cst::form tree) 20 | (cst::supplied-p tree))) 21 | 22 | (defmethod unparse ((tree cst::ordinary-key-parameter)) 23 | (list (list (cst::keyword tree) (cst::name tree)) 24 | (cst::form tree) 25 | (cst::supplied-p tree))) 26 | 27 | (defmethod unparse ((tree cst::aux-parameter)) 28 | (list (cst::name tree) 29 | (cst::form tree))) 30 | 31 | (defmethod unparse ((tree cst::generic-function-optional-parameter)) 32 | (cst::name tree)) 33 | 34 | (defmethod unparse ((tree cst::generic-function-key-parameter)) 35 | (list (list (cst::keyword tree) (cst::name tree)))) 36 | 37 | (defmethod unparse ((tree cst::specialized-required-parameter)) 38 | (list (cst::name tree) (cst::specializer tree))) 39 | -------------------------------------------------------------------------------- /Lambda-list/client.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass client () ()) 4 | 5 | (defclass sbcl (client) ()) 6 | 7 | (defclass sicl (client) ()) 8 | 9 | (defclass clasp (client) ()) 10 | 11 | (defclass ecl (client) ()) 12 | 13 | (defclass ccl (client) ()) 14 | -------------------------------------------------------------------------------- /Lambda-list/concrete-syntax-tree-lambda-list.asd: -------------------------------------------------------------------------------- 1 | (defsystem "concrete-syntax-tree-lambda-list" 2 | :depends-on ("concrete-syntax-tree") 3 | :serial t 4 | :components ((:file "client") 5 | (:file "ensure-proper") 6 | (:file "grammar-symbols") 7 | (:file "lambda-list-keywords") 8 | (:file "grammar") 9 | (:file "standard-grammars") 10 | (:file "earley-item") 11 | (:file "earley-state") 12 | (:file "parser") 13 | (:file "scanner-action") 14 | (:file "earley") 15 | (:file "parse-top-levels") 16 | (:file "unparse")) 17 | :in-order-to ((test-op (test-op "concrete-syntax-tree-lambda-list/test")))) 18 | 19 | (defsystem "concrete-syntax-tree-lambda-list/test" 20 | :depends-on ("fiveam" 21 | "concrete-syntax-tree-lambda-list") 22 | :components ((:module "Test" 23 | :serial t 24 | :components ((:file "packages") 25 | (:file "random-lambda-list") 26 | (:file "compare-parse-trees") 27 | (:file "parsers") 28 | (:file "unparse") 29 | (:file "test")))) 30 | :perform (test-op (operation component) 31 | (when (and (not (uiop:symbol-call '#:concrete-syntax-tree-lambda-list-test 32 | '#:run-tests)) 33 | (boundp 'cl-user::*result*)) 34 | (setf (symbol-value 'cl-user::*result*) nil)))) 35 | -------------------------------------------------------------------------------- /Lambda-list/earley-item.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass earley-item () 4 | ((%rule :initarg :rule :reader rule) 5 | (%dot-position :initarg :dot-position :reader dot-position) 6 | (%origin :initarg :origin :reader origin) 7 | (%parse-trees :initarg :parse-trees :reader parse-trees))) 8 | 9 | (defmethod print-object ((object earley-item) stream) 10 | (let ((rule (rule object)) 11 | (pos (dot-position object))) 12 | (print-unreadable-object (rule stream :type t) 13 | (format stream "~s <- " (left-hand-side rule)) 14 | (loop for symbol in (right-hand-side rule) 15 | for i from 0 16 | do (when (= pos i) 17 | (format stream " . ")) 18 | (format stream "~s " symbol)) 19 | (when (= pos (length (right-hand-side rule))) 20 | (format stream " . ")) 21 | (terpri stream)))) 22 | 23 | (defgeneric item-equal (item1 item2)) 24 | 25 | (defmethod item-equal ((item1 earley-item) (item2 earley-item)) 26 | (and (eq (rule item1) (rule item2)) 27 | (eq (dot-position item1) (dot-position item2)) 28 | (eq (origin item1) (origin item2)))) 29 | -------------------------------------------------------------------------------- /Lambda-list/earley-state.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass earley-state () 4 | ((%items :initform '() :accessor items))) 5 | 6 | (defgeneric possibly-add-item (item state)) 7 | 8 | (defmethod possibly-add-item ((item earley-item) (state earley-state)) 9 | (unless (find item (items state) :test #'item-equal) 10 | (setf (items state) 11 | (nconc (items state) (cl:list item))))) 12 | -------------------------------------------------------------------------------- /Lambda-list/earley.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defgeneric completer-action (symbol grammar origin state)) 4 | 5 | (defmethod completer-action 6 | ((symbol grammar-symbol) 7 | (grammar grammar) 8 | (origin earley-state) 9 | (state earley-state)) 10 | (loop for item in (items origin) 11 | for rule = (rule item) 12 | for length = (length (right-hand-side rule)) 13 | for dot-position = (dot-position item) 14 | when (and (< dot-position length) 15 | (let* ((element (elt (right-hand-side rule) dot-position)) 16 | (type (if (cl:consp element) (cadr element) element))) 17 | (typep symbol type))) 18 | do (loop for i from (1+ dot-position) 19 | do (let ((new (make-instance 'earley-item 20 | :rule (rule item) 21 | :dot-position i 22 | :origin (origin item) 23 | :parse-trees 24 | (cl:cons symbol (parse-trees item))))) 25 | (possibly-add-item new state)) 26 | while (and (< i (length (right-hand-side rule))) 27 | (nullable-p (elt (right-hand-side rule) i)))))) 28 | 29 | (defgeneric predictor-action (symbol grammar state)) 30 | 31 | (defmethod predictor-action 32 | ((symbol grammar-symbol) (grammar grammar) (state earley-state)) 33 | (loop for rule in (rules grammar) 34 | when (typep symbol (left-hand-side rule)) 35 | do (loop for i from 0 36 | until (= i (length (right-hand-side rule))) 37 | while (nullable-p (elt (right-hand-side rule) i)) 38 | do (let ((new (make-instance 'earley-item 39 | :rule rule 40 | :dot-position i 41 | :origin state 42 | :parse-trees '()))) 43 | (possibly-add-item new state)) 44 | finally (let ((new (make-instance 'earley-item 45 | :rule rule 46 | :dot-position i 47 | :origin state 48 | :parse-trees '()))) 49 | (possibly-add-item new state))))) 50 | 51 | (defun all-items (rule origin parse-trees dot-position) 52 | (loop with right-hand-side = (right-hand-side rule) 53 | with length = (length right-hand-side) 54 | for i from dot-position 55 | collect (make-instance 'earley-item 56 | :rule rule 57 | :origin origin 58 | :parse-trees parse-trees 59 | :dot-position i) 60 | while (and (< i length) (nullable-p (elt right-hand-side i))))) 61 | 62 | (defgeneric process-current-state (parser)) 63 | 64 | (defmethod process-current-state ((parser parser)) 65 | (let ((states (remaining-states parser)) 66 | (client (client parser)) 67 | (lambda-list (lambda-list parser)) 68 | (remaining-input (remaining-input parser))) 69 | (loop with grammar = (grammar parser) 70 | with state = (car states) 71 | for remaining-items = (items state) then (cdr remaining-items) 72 | until (cl:null remaining-items) 73 | do (let* ((item (car remaining-items)) 74 | (pos (dot-position item)) 75 | (rule (rule item)) 76 | (lhs (left-hand-side rule)) 77 | (rhs (right-hand-side rule))) 78 | (if (= pos (length rhs)) 79 | (let* ((lhs-class (find-class lhs)) 80 | (proto (make-instance lhs-class 81 | :children (reverse (parse-trees item))))) 82 | (completer-action proto grammar (origin item) state)) 83 | (let* ((terminal (cl:nth pos rhs)) 84 | (terminal-class 85 | (find-class (if (cl:consp terminal) 86 | (cadr terminal) 87 | terminal))) 88 | (proto (make-instance terminal-class)) 89 | (scan-result 90 | (if (or (null remaining-input) 91 | (atom remaining-input)) 92 | nil 93 | (scanner-action client 94 | item 95 | lambda-list 96 | (if (cl:consp terminal) 97 | terminal 98 | proto) 99 | (first remaining-input))))) 100 | (loop with next-state = (cadr states) 101 | for item in scan-result 102 | for items = (cl:cons item 103 | (all-items (rule item) 104 | (origin item) 105 | (parse-trees item) 106 | (dot-position item))) 107 | do (loop for item in items 108 | do (possibly-add-item item next-state))) 109 | (predictor-action proto grammar state))))))) 110 | 111 | (defgeneric parse-step (parser)) 112 | 113 | (defmethod parse-step ((parser parser)) 114 | (process-current-state parser) 115 | (unless (or (null (remaining-input parser)) 116 | (atom (remaining-input parser))) 117 | (setf (remaining-input parser) (rest (remaining-input parser)))) 118 | (cl:pop (remaining-states parser))) 119 | 120 | (defgeneric parse (parser)) 121 | 122 | (defmethod parse ((parser parser)) 123 | (loop repeat (1+ (length (raw (all-input parser)))) 124 | do (parse-step parser))) 125 | -------------------------------------------------------------------------------- /Lambda-list/ensure-proper.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defgeneric ensure-proper (lambda-list)) 4 | 5 | (defmethod ensure-proper ((lambda-list atom-cst)) 6 | (if (null lambda-list) 7 | lambda-list 8 | (list (make-instance 'atom-cst :raw '&rest) 9 | lambda-list))) 10 | 11 | (defmethod ensure-proper ((lambda-list cons-cst)) 12 | (let ((rest (ensure-proper (rest lambda-list)))) 13 | (if (eq rest (rest lambda-list)) 14 | lambda-list 15 | (make-instance 'cons-cst 16 | :source (source lambda-list) 17 | :raw (cl:cons (raw (first lambda-list)) (raw rest)) 18 | :first (first lambda-list) 19 | :rest rest)))) 20 | -------------------------------------------------------------------------------- /Lambda-list/grammar-symbols.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; This is the root class of all grammar symbols. 4 | (defclass grammar-symbol () 5 | ()) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;;; 9 | ;;; Parameter groups. 10 | ;;; 11 | ;;; A parameter group represents a list of parameters of the same kind 12 | ;;; and that appear together in a lambda list. 13 | 14 | ;;; The root of all classes that represent parameter groups. 15 | (defclass parameter-group (grammar-symbol) 16 | ()) 17 | 18 | ;;; Returns true iff the given parameter group accepts a variable 19 | ;;; number of arguments. This is consulted to see whether a check 20 | ;;; for too many arguments should be inserted when constructing bindings. 21 | (defgeneric parameter-group-varargs-p (client parameter-group)) 22 | 23 | (defclass singleton-parameter-group-mixin () 24 | ((%parameter :initarg :parameter :reader parameter))) 25 | 26 | (defmethod print-object ((object singleton-parameter-group-mixin) stream) 27 | (print-unreadable-object (object stream :type t :identity t) 28 | (format stream "parameter: ~s" (parameter object)))) 29 | 30 | (defclass multi-parameter-group-mixin () 31 | ((%parameters :initarg :parameters :reader parameters))) 32 | 33 | (defmethod print-object ((object multi-parameter-group-mixin) stream) 34 | (print-unreadable-object (object stream :type t :identity t) 35 | (format stream "parameters: ~s" (parameters object)))) 36 | 37 | ;;; An instance of this class represents a parameter group that does 38 | ;;; not have any associated lambda-list keyword. Every different kind 39 | ;;; of required parameter group is a subclass of this class. 40 | (defclass implicit-parameter-group (parameter-group multi-parameter-group-mixin) 41 | ()) 42 | 43 | (defmethod parameter-group-varargs-p 44 | (client (parameter-group implicit-parameter-group)) 45 | (declare (ignore client)) 46 | nil) 47 | 48 | ;;; When an instance of an implicit parameter group is created, we 49 | ;;; initialize the parameters from the CHILDREN keyword passed by the 50 | ;;; completer. 51 | (defmethod initialize-instance :after 52 | ((parameter-group implicit-parameter-group) &key children) 53 | (reinitialize-instance parameter-group 54 | :parameters children)) 55 | 56 | ;;; An instance of this class represents a parameter group that has an 57 | ;;; associated lambda-list keyword. 58 | (defclass explicit-parameter-group (parameter-group) 59 | ((%keyword :initarg :keyword :reader keyword))) 60 | 61 | (defclass explicit-multi-parameter-group 62 | (explicit-parameter-group multi-parameter-group-mixin) 63 | ()) 64 | 65 | ;;; When an instance of an explicit parameter group is created, we 66 | ;;; want to separate the keyword from the list of parameters. 67 | (defmethod initialize-instance :after 68 | ((parameter-group explicit-multi-parameter-group) &key children) 69 | (reinitialize-instance parameter-group 70 | :keyword (car children) 71 | :parameters (cdr children))) 72 | 73 | (defclass ordinary-required-parameter-group (implicit-parameter-group) 74 | ()) 75 | 76 | (defclass optional-parameter-group (explicit-multi-parameter-group) 77 | ()) 78 | 79 | (defmethod parameter-group-varargs-p 80 | (client (parameter-group optional-parameter-group)) 81 | (declare (ignore client)) 82 | nil) 83 | 84 | (defclass ordinary-optional-parameter-group (optional-parameter-group) 85 | ()) 86 | 87 | (defclass key-parameter-group (explicit-multi-parameter-group) 88 | (;; This slot can be either &ALLOW-OTHER-KEYS, if that lambda-list 89 | ;; keyword is present, or NIL if it is absent. 90 | (%allow-other-keys :initarg :allow-other-keys :reader allow-other-keys))) 91 | 92 | (defmethod parameter-group-varargs-p 93 | (client (parameter-group key-parameter-group)) 94 | (declare (ignore client)) 95 | t) 96 | 97 | (defclass ordinary-key-parameter-group (key-parameter-group) 98 | ()) 99 | 100 | (defmethod initialize-instance :after 101 | ((parameter-group key-parameter-group) &key children) 102 | (let ((allow-other-keys (car (last children)))) 103 | (reinitialize-instance 104 | parameter-group 105 | :keyword (car children) 106 | :parameters (cdr (if (typep allow-other-keys 'keyword-allow-other-keys) 107 | (butlast children) 108 | children)) 109 | :allow-other-keys (if (typep allow-other-keys 'keyword-allow-other-keys) 110 | allow-other-keys 111 | nil)))) 112 | 113 | (defclass generic-function-key-parameter-group (key-parameter-group) 114 | ()) 115 | 116 | (defclass aux-parameter-group (explicit-multi-parameter-group) 117 | ()) 118 | 119 | (defmethod parameter-group-varargs-p 120 | (client (parameter-group aux-parameter-group)) 121 | (declare (ignore client)) 122 | nil) 123 | 124 | (defclass generic-function-optional-parameter-group (optional-parameter-group) 125 | ()) 126 | 127 | (defclass specialized-required-parameter-group (implicit-parameter-group) 128 | ()) 129 | 130 | (defclass destructuring-required-parameter-group (implicit-parameter-group) 131 | ()) 132 | 133 | (defclass destructuring-optional-parameter-group (optional-parameter-group) 134 | ()) 135 | 136 | (defclass destructuring-key-parameter-group (key-parameter-group) 137 | ()) 138 | 139 | ;;; This class is the root class of parameter groups that take a 140 | ;;; keyword and a single parameter, such as &WHOLE, &ENVIRONMENT, 141 | ;;; &REST, &BODY. 142 | (defclass singleton-parameter-group 143 | (explicit-parameter-group singleton-parameter-group-mixin) 144 | ()) 145 | 146 | ;;; When an instance of a singleton parameter group is created, we 147 | ;;; want to separate the keyword from the parameter itself. 148 | (defmethod initialize-instance :after 149 | ((parameter singleton-parameter-group) &key children) 150 | (reinitialize-instance parameter 151 | :keyword (car children) 152 | :parameter (cadr children))) 153 | 154 | (defclass rest-parameter-group (singleton-parameter-group) 155 | ()) 156 | 157 | (defmethod parameter-group-varargs-p 158 | (client (parameter-group rest-parameter-group)) 159 | (declare (ignore client)) 160 | t) 161 | 162 | (defclass ordinary-rest-parameter-group (rest-parameter-group) 163 | ()) 164 | 165 | (defclass destructuring-rest-parameter-group (rest-parameter-group) 166 | ()) 167 | 168 | (defclass environment-parameter-group (singleton-parameter-group) 169 | ()) 170 | 171 | (defmethod parameter-group-varargs-p 172 | (client (parameter-group environment-parameter-group)) 173 | (declare (ignore client)) 174 | nil) 175 | 176 | (defclass whole-parameter-group (singleton-parameter-group) 177 | ()) 178 | 179 | (defmethod parameter-group-varargs-p 180 | (client (parameter-group whole-parameter-group)) 181 | (declare (ignore client)) 182 | nil) 183 | 184 | (defclass ordinary-whole-parameter-group (whole-parameter-group) 185 | ()) 186 | 187 | ;;; CLHS is somewhat self-contradictory about whether &whole parameters 188 | ;;; destructure. The text in 3.4.4 refers to a &whole parameter as a 189 | ;;; "single variable", but 3.4.4.1.2 describes it as a destructuring 190 | ;;; pattern. The ANSI tests (which are not part of the standard) 191 | ;;; expect destructuring &whole in the destructuring-bind.20 and 192 | ;;; macrolet.36 tests. We do support &whole destructuring. 193 | (defclass destructuring-whole-parameter-group (whole-parameter-group) 194 | ()) 195 | 196 | ;;; This class is the root of all classes that correspond to 197 | ;;; individual parameters. Instance of (subclasses of) this class are 198 | ;;; handled by the scanner. 199 | (defclass parameter (grammar-symbol) 200 | ;; NAME can be either an atom, or a nested destructuring-lambda-list, 201 | ;; depending on the actual class. I.e., a simple-variable will always 202 | ;; have an atom, but a destructuring-key-parameter will have a 203 | ;; destructuring-lambda-list. 204 | ((%name :initarg :name :reader name))) 205 | 206 | (defclass form-mixin () 207 | ((%form :initform nil :initarg :form :reader form))) 208 | 209 | (defclass supplied-p-mixin () 210 | ((%supplied-p :initform nil :initarg :supplied-p :reader supplied-p))) 211 | 212 | (defclass keyword-mixin () 213 | ((%keyword :initarg :keyword :reader keyword))) 214 | 215 | (defclass simple-variable (parameter) 216 | ()) 217 | 218 | (defclass ordinary-optional-parameter (parameter form-mixin supplied-p-mixin) 219 | ()) 220 | 221 | (defclass ordinary-key-parameter 222 | (parameter form-mixin supplied-p-mixin keyword-mixin) 223 | ()) 224 | 225 | (defclass generic-function-key-parameter (parameter keyword-mixin) 226 | ()) 227 | 228 | (defclass aux-parameter (parameter form-mixin) 229 | ()) 230 | 231 | ;;; A generic-function optional parameter differs from an ordinary 232 | ;;; optional parameter in that it can have neither a form to determine 233 | ;;; a default value, nor an associated supplied-p parameter. 234 | (defclass generic-function-optional-parameter (parameter) 235 | ()) 236 | 237 | (defclass specialized-required-parameter (parameter) 238 | ((%specializer :initarg :specializer :reader specializer ))) 239 | 240 | ;;; This class will never be part of a parse tree. When the scanner 241 | ;;; sees an instance of this class, it looks at the input to determine 242 | ;;; whether it is a symbol or a CONS cell. If it is a symbol, it 243 | ;;; creates a SIMPLE-VARIABLE, and if it is a CONS cell, it 244 | ;;; recursively parses the list as a DESTRUCTURING-LAMBDA-LIST which 245 | ;;; then becomes the resulting parse tree. 246 | (defclass destructuring-parameter (grammar-symbol) ()) 247 | 248 | ;;; These two classes do show up in parse trees. 249 | (defclass destructuring-optional-parameter 250 | (parameter form-mixin supplied-p-mixin) 251 | ()) 252 | 253 | (defclass destructuring-key-parameter 254 | (parameter form-mixin supplied-p-mixin keyword-mixin) 255 | ()) 256 | 257 | (defclass lambda-list-keyword (grammar-symbol) 258 | ((%name :initarg :name :reader name))) 259 | 260 | (defclass keyword-optional (lambda-list-keyword) ()) 261 | 262 | (defclass keyword-rest (lambda-list-keyword) ()) 263 | 264 | (defclass keyword-body (lambda-list-keyword) ()) 265 | 266 | (defclass keyword-key (lambda-list-keyword) ()) 267 | 268 | (defclass keyword-allow-other-keys (lambda-list-keyword) ()) 269 | 270 | (defclass keyword-aux (lambda-list-keyword) ()) 271 | 272 | (defclass keyword-environment (lambda-list-keyword) ()) 273 | 274 | (defclass keyword-whole (lambda-list-keyword) ()) 275 | 276 | (defclass lambda-list-type (grammar-symbol) 277 | ((%children :initarg :children :reader children))) 278 | 279 | (defmethod print-object ((object lambda-list-type) stream) 280 | (print-unreadable-object (object stream :type t :identity t) 281 | (format stream "children: ~s" (children object)))) 282 | 283 | (defclass ordinary-lambda-list (lambda-list-type) ()) 284 | 285 | (defclass generic-function-lambda-list (lambda-list-type) ()) 286 | 287 | (defclass specialized-lambda-list (lambda-list-type) ()) 288 | 289 | (defclass macro-lambda-list (lambda-list-type) ()) 290 | 291 | (defclass destructuring-lambda-list (lambda-list-type) ()) 292 | 293 | (defclass boa-lambda-list (lambda-list-type) ()) 294 | 295 | (defclass defsetf-lambda-list (lambda-list-type) ()) 296 | 297 | (defclass deftype-lambda-list (lambda-list-type) ()) 298 | 299 | (defclass define-modify-macro-lambda-list (lambda-list-type) ()) 300 | 301 | (defclass define-method-combination-lambda-list (lambda-list-type) ()) 302 | 303 | (defclass target (grammar-symbol) 304 | ((%children :initarg :children :reader children))) 305 | -------------------------------------------------------------------------------- /Lambda-list/grammar.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass rule () 4 | ((&left-hand-side :initarg :left-hand-side :reader left-hand-side) 5 | (&right-hand-side :initarg :right-hand-side :reader right-hand-side))) 6 | 7 | (defmethod print-object ((object rule) stream) 8 | (print-unreadable-object (object stream :type t) 9 | (format stream "~s <- " (left-hand-side object)) 10 | (loop for symbol in (right-hand-side object) 11 | do (format stream "~s " symbol)) 12 | (terpri stream))) 13 | 14 | (defclass grammar () 15 | ((%target-rule :initarg :target-rule :reader target-rule) 16 | (%rules :initarg :rules :reader rules))) 17 | 18 | (defun nullable-p (right-hand-side-element) 19 | (and (cl:consp right-hand-side-element) 20 | (member (car right-hand-side-element) '(? *) :test #'eq))) 21 | 22 | ;;; Generate a grammar from a target and description, making sure to 23 | ;;; prune out all rules irrelevant to the target, so that no extra 24 | ;;; effort is expended while parsing. This function should only be 25 | ;;; called at grammar generation time. 26 | (defun generate-grammar (target grammar-description) 27 | (let ((relevant-rule-descriptions '()) 28 | (relevant-symbols (cl:list target)) 29 | (seen-symbols '())) 30 | (loop (unless relevant-symbols 31 | (return)) 32 | (let ((symbol (cl:pop relevant-symbols))) 33 | (unless (member symbol seen-symbols) 34 | (dolist (description grammar-description) 35 | (when (eq (car description) symbol) 36 | (push description relevant-rule-descriptions) 37 | (dolist (item (cddr description)) 38 | (push symbol seen-symbols) 39 | (push (if (symbolp item) 40 | item 41 | (cl:second item)) 42 | relevant-symbols))))))) 43 | (make-instance 'grammar 44 | :target-rule (make-instance 'rule 45 | :left-hand-side 'target 46 | :right-hand-side (cl:list target)) 47 | :rules (mapcar (lambda (rule-description) 48 | (make-instance 'rule 49 | :left-hand-side (car rule-description) 50 | :right-hand-side (cddr rule-description))) 51 | relevant-rule-descriptions)))) 52 | -------------------------------------------------------------------------------- /Lambda-list/lambda-list-keywords.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defgeneric all-lambda-list-keywords (client) 4 | (:method-combination append)) 5 | 6 | (defmethod all-lambda-list-keywords append (client) 7 | (declare (ignore client)) 8 | '(&optional 9 | &key 10 | &allow-other-keys 11 | &rest 12 | &body 13 | &aux 14 | &environment 15 | &whole)) 16 | 17 | #+sbcl 18 | (defmethod all-lambda-list-keywords append ((client sbcl)) 19 | '(sb-int:&more)) 20 | 21 | (defgeneric allowed-lambda-list-keywords (client lambda-list) 22 | (:method-combination append)) 23 | 24 | (defmethod allowed-lambda-list-keywords append 25 | (client (lambda-list ordinary-lambda-list)) 26 | (declare (ignore client)) 27 | '(&optional 28 | &key 29 | &allow-other-keys 30 | &rest 31 | &aux)) 32 | 33 | (defmethod allowed-lambda-list-keywords append 34 | (client (lambda-list generic-function-lambda-list)) 35 | (declare (ignore client)) 36 | '(&optional 37 | &key 38 | &allow-other-keys 39 | &rest)) 40 | 41 | (defmethod allowed-lambda-list-keywords append 42 | (client (lambda-list specialized-lambda-list)) 43 | (declare (ignore client)) 44 | '(&optional 45 | &key 46 | &allow-other-keys 47 | &rest 48 | &aux)) 49 | 50 | (defmethod allowed-lambda-list-keywords append 51 | (client (lambda-list macro-lambda-list)) 52 | (declare (ignore client)) 53 | '(&optional 54 | &key 55 | &allow-other-keys 56 | &rest 57 | &body 58 | &aux 59 | &environment 60 | &whole)) 61 | 62 | (defmethod allowed-lambda-list-keywords append 63 | (client (lambda-list destructuring-lambda-list)) 64 | (declare (ignore client)) 65 | '(&optional 66 | &key 67 | &allow-other-keys 68 | &rest 69 | &body 70 | &aux 71 | &whole)) 72 | 73 | (defmethod allowed-lambda-list-keywords append 74 | (client (lambda-list defsetf-lambda-list)) 75 | (declare (ignore client)) 76 | '(&optional 77 | &key 78 | &allow-other-keys 79 | &rest 80 | &environment)) 81 | 82 | (defmethod allowed-lambda-list-keywords append 83 | (client (lambda-list define-modify-macro-lambda-list)) 84 | (declare (ignore client)) 85 | '(&optional 86 | &rest)) 87 | 88 | (defmethod allowed-lambda-list-keywords append 89 | (client (lambda-list define-method-combination-lambda-list)) 90 | (declare (ignore client)) 91 | '(&optional 92 | &key 93 | &allow-other-keys 94 | &rest 95 | &aux 96 | &whole)) 97 | -------------------------------------------------------------------------------- /Lambda-list/parse-top-levels.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defun parse-top-level (client grammar class lambda-list &key (error-p t)) 4 | (let ((p (make-instance 'cst::parser 5 | :grammar grammar 6 | :input lambda-list 7 | :lambda-list (make-instance class) 8 | :client client))) 9 | (parse p) 10 | (let ((item (find-final-item p))) 11 | (if (cl:null item) 12 | (if error-p (error "Parse failed") nil) 13 | (car (parse-trees item)))))) 14 | 15 | (defmacro define-top-level-parser (name grammar type) 16 | `(defun ,name (client lambda-list &key (error-p t)) 17 | (parse-top-level client ,grammar ',type lambda-list 18 | :error-p error-p))) 19 | 20 | (define-top-level-parser parse-ordinary-lambda-list 21 | *ordinary-lambda-list-grammar* 22 | ordinary-lambda-list) 23 | 24 | (define-top-level-parser parse-generic-function-lambda-list 25 | *generic-function-lambda-list-grammar* 26 | generic-function-lambda-list) 27 | 28 | (define-top-level-parser parse-specialized-lambda-list 29 | *specialized-lambda-list-grammar* 30 | specialized-lambda-list) 31 | 32 | (define-top-level-parser parse-defsetf-lambda-list 33 | *defsetf-lambda-list-grammar* 34 | defsetf-lambda-list) 35 | 36 | (define-top-level-parser parse-define-modify-macro-lambda-list 37 | *define-modify-macro-lambda-list-grammar* 38 | define-modify-macro-lambda-list) 39 | 40 | (define-top-level-parser parse-define-method-combination-lambda-list 41 | *define-method-combination-lambda-list-grammar* 42 | define-method-combination-lambda-list) 43 | 44 | (define-top-level-parser parse-destructuring-lambda-list 45 | *destructuring-lambda-list-grammar* 46 | destructuring-lambda-list) 47 | 48 | (define-top-level-parser parse-macro-lambda-list 49 | *macro-lambda-list-grammar* 50 | macro-lambda-list) 51 | -------------------------------------------------------------------------------- /Lambda-list/parser.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass parser () 4 | ((%client :initarg :client :reader client) 5 | (%lambda-list :initarg :lambda-list :reader lambda-list) 6 | (%grammar :initarg :grammar :reader grammar) 7 | (%all-states :initarg :states :reader all-states) 8 | (%all-input :initarg :input :reader all-input) 9 | (%remaining-states :initarg :states :accessor remaining-states) 10 | (%remaining-input :initarg :input :accessor remaining-input))) 11 | 12 | (defmethod initialize-instance :after ((object parser) &key) 13 | (let* ((states (loop repeat (1+ (length (raw (all-input object)))) 14 | collect (make-instance 'earley-state))) 15 | (target-rule (target-rule (grammar object))) 16 | (item (make-instance 'earley-item 17 | :parse-trees '() 18 | :origin (car states) 19 | :dot-position 0 20 | :rule target-rule))) 21 | (push item (items (car states))) 22 | (reinitialize-instance 23 | object 24 | :states states))) 25 | 26 | (defun find-final-item (parser) 27 | (let ((initial-state (car (all-states parser))) 28 | (final-state (car (cl:last (all-states parser))))) 29 | (find-if (lambda (item) 30 | (let* ((rule (rule item)) 31 | (len (length (right-hand-side rule))) 32 | (pos (dot-position item))) 33 | (and (eq (left-hand-side (rule item)) 34 | 'target) 35 | (= pos len) 36 | (eq (origin item) initial-state)))) 37 | (items final-state)))) 38 | 39 | (defun find-final-parse-tree (parser) 40 | (let ((item (find-final-item parser))) 41 | (if (cl:null item) 42 | nil 43 | (car (parse-trees item))))) 44 | -------------------------------------------------------------------------------- /Lambda-list/standard-grammars.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defparameter *ordinary-required-parameter-group* 4 | '((ordinary-required-parameter-group <- 5 | (* simple-variable)))) 6 | 7 | (defparameter *ordinary-optional-parameter-group* 8 | '((ordinary-optional-parameter-group <- 9 | keyword-optional 10 | (* ordinary-optional-parameter)))) 11 | 12 | (defparameter *ordinary-rest-parameter-group* 13 | '((ordinary-rest-parameter-group <- 14 | keyword-rest 15 | simple-variable))) 16 | 17 | (defparameter *ordinary-key-parameter-group* 18 | '((ordinary-key-parameter-group <- 19 | keyword-key 20 | (* ordinary-key-parameter) 21 | (? keyword-allow-other-keys)))) 22 | 23 | (defparameter *aux-parameter-group* 24 | '((aux-parameter-group <- 25 | keyword-aux 26 | (* aux-parameter)))) 27 | 28 | (defparameter *ordinary-lambda-list* 29 | '((ordinary-lambda-list <- 30 | ordinary-required-parameter-group 31 | (? ordinary-optional-parameter-group) 32 | (? ordinary-rest-parameter-group) 33 | (? ordinary-key-parameter-group) 34 | (? aux-parameter-group)))) 35 | 36 | (defparameter *generic-function-optional-parameter-group* 37 | '((generic-function-optional-parameter-group <- 38 | keyword-optional 39 | (* generic-function-optional-parameter)))) 40 | 41 | (defparameter *generic-function-key-parameter-group* 42 | '((generic-function-key-parameter-group <- 43 | keyword-key 44 | (* generic-function-key-parameter) 45 | (? keyword-allow-other-keys)))) 46 | 47 | (defparameter *generic-function-lambda-list* 48 | '((generic-function-lambda-list <- 49 | ordinary-required-parameter-group 50 | (? generic-function-optional-parameter-group) 51 | (? ordinary-rest-parameter-group) 52 | (? generic-function-key-parameter-group)))) 53 | 54 | (defparameter *specialized-required-parameter-group* 55 | '((specialized-required-parameter-group <- 56 | (* specialized-required-parameter)))) 57 | 58 | (defparameter *specialized-lambda-list* 59 | '((specialized-lambda-list <- 60 | specialized-required-parameter-group 61 | (? ordinary-optional-parameter-group) 62 | (? ordinary-rest-parameter-group) 63 | (? ordinary-key-parameter-group) 64 | (? aux-parameter-group)))) 65 | 66 | (defparameter *environment-parameter-group* 67 | '((environment-parameter-group <- 68 | keyword-environment 69 | simple-variable))) 70 | 71 | (defparameter *defsetf-lambda-list* 72 | '((defsetf-lambda-list <- 73 | ordinary-required-parameter-group 74 | (? ordinary-optional-parameter-group) 75 | (? ordinary-rest-parameter-group) 76 | (? ordinary-key-parameter-group) 77 | (? environment-parameter-group)))) 78 | 79 | (defparameter *define-modify-macro-lambda-list* 80 | '((define-modify-macro-lambda-list <- 81 | ordinary-required-parameter-group 82 | (? ordinary-optional-parameter-group) 83 | (? ordinary-rest-parameter-group)))) 84 | 85 | (defparameter *ordinary-whole-parameter-group* 86 | '((ordinary-whole-parameter-group <- 87 | keyword-whole 88 | simple-variable))) 89 | 90 | (defparameter *define-method-combination-lambda-list* 91 | '((define-method-combination-lambda-list <- 92 | (? ordinary-whole-parameter-group) 93 | ordinary-required-parameter-group 94 | (? ordinary-optional-parameter-group) 95 | (? ordinary-rest-parameter-group) 96 | (? ordinary-key-parameter-group) 97 | (? aux-parameter-group)))) 98 | 99 | (defparameter *destructuring-whole-parameter-group* 100 | '((destructuring-whole-parameter-group <- 101 | keyword-whole 102 | destructuring-parameter))) 103 | 104 | (defparameter *destructuring-required-parameter-group* 105 | '((destructuring-required-parameter-group <- 106 | (* destructuring-parameter)))) 107 | 108 | (defparameter *destructuring-optional-parameter-group* 109 | '((destructuring-optional-parameter-group <- 110 | keyword-optional 111 | (* destructuring-optional-parameter)))) 112 | 113 | (defparameter *destructuring-key-parameter-group* 114 | '((destructuring-key-parameter-group <- 115 | keyword-key 116 | (* destructuring-key-parameter) 117 | (? keyword-allow-other-keys)))) 118 | 119 | (defparameter *destructuring-rest-parameter-group* 120 | '((destructuring-rest-parameter-group <- 121 | keyword-rest 122 | destructuring-parameter) 123 | (destructuring-rest-parameter-group <- 124 | keyword-body 125 | destructuring-parameter))) 126 | 127 | (defparameter *destructuring-lambda-list* 128 | `((destructuring-lambda-list <- 129 | (? destructuring-whole-parameter-group) 130 | destructuring-required-parameter-group 131 | (? ordinary-optional-parameter-group) 132 | (? destructuring-rest-parameter-group) 133 | (? ordinary-key-parameter-group) 134 | (? aux-parameter-group)))) 135 | 136 | (defparameter *macro-lambda-list* 137 | `((macro-lambda-list <- 138 | (? destructuring-whole-parameter-group) 139 | (? environment-parameter-group) 140 | destructuring-required-parameter-group 141 | (? environment-parameter-group) 142 | (? destructuring-optional-parameter-group) 143 | (? environment-parameter-group) 144 | (? destructuring-rest-parameter-group) 145 | (? environment-parameter-group) 146 | (? destructuring-key-parameter-group) 147 | (? environment-parameter-group) 148 | (? aux-parameter-group) 149 | (? environment-parameter-group)))) 150 | 151 | (defparameter *standard-grammar* 152 | (append *ordinary-required-parameter-group* 153 | *ordinary-optional-parameter-group* 154 | *ordinary-rest-parameter-group* 155 | *ordinary-key-parameter-group* 156 | *aux-parameter-group* 157 | *ordinary-lambda-list* 158 | *generic-function-optional-parameter-group* 159 | *generic-function-key-parameter-group* 160 | *generic-function-lambda-list* 161 | *specialized-required-parameter-group* 162 | *specialized-lambda-list* 163 | *environment-parameter-group* 164 | *defsetf-lambda-list* 165 | *define-modify-macro-lambda-list* 166 | *ordinary-whole-parameter-group* 167 | *define-method-combination-lambda-list* 168 | *destructuring-whole-parameter-group* 169 | *destructuring-required-parameter-group* 170 | *destructuring-optional-parameter-group* 171 | *destructuring-key-parameter-group* 172 | *destructuring-rest-parameter-group* 173 | *destructuring-lambda-list* 174 | *macro-lambda-list*)) 175 | 176 | (defparameter *ordinary-lambda-list-grammar* 177 | (generate-grammar 'ordinary-lambda-list *standard-grammar*)) 178 | 179 | (defparameter *generic-function-lambda-list-grammar* 180 | (generate-grammar 'generic-function-lambda-list *standard-grammar*)) 181 | 182 | (defparameter *specialized-lambda-list-grammar* 183 | (generate-grammar 'specialized-lambda-list *standard-grammar*)) 184 | 185 | (defparameter *defsetf-lambda-list-grammar* 186 | (generate-grammar 'defsetf-lambda-list *standard-grammar*)) 187 | 188 | (defparameter *define-modify-macro-lambda-list-grammar* 189 | (generate-grammar 'define-modify-macro-lambda-list *standard-grammar*)) 190 | 191 | (defparameter *define-method-combination-lambda-list-grammar* 192 | (generate-grammar 'define-method-combination-lambda-list *standard-grammar*)) 193 | 194 | (defparameter *destructuring-lambda-list-grammar* 195 | (generate-grammar 'destructuring-lambda-list *standard-grammar*)) 196 | 197 | (defparameter *macro-lambda-list-grammar* 198 | (generate-grammar 'macro-lambda-list *standard-grammar*)) 199 | -------------------------------------------------------------------------------- /Lambda-list/unparse.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;;; This file defines an "unparsing" system. Given a parsed lambda list, a 4 | ;;;; lambda list intended for human consumption is returned. The unparse 5 | ;;;; should resemble the originally parsed lambda list, but there is no 6 | ;;;; exactness requirement. 7 | ;;;; This is useful for displaying lambda lists to a user, 8 | ;;;; for example in error reports. 9 | 10 | (defgeneric unparse-lambda-list (client lambda-list)) 11 | 12 | (defgeneric unparse-parameter-group (client parameter-group)) 13 | 14 | (defgeneric unparse-parameter (client parameter)) 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | ;;; 18 | ;;; Methods 19 | 20 | (defmethod unparse-lambda-list (client (lambda-list lambda-list-type)) 21 | (loop for parameter-group in (children lambda-list) 22 | appending (unparse-parameter-group client parameter-group))) 23 | 24 | ;;; 25 | 26 | (defmethod unparse-parameter-group 27 | (client (parameter-group singleton-parameter-group)) 28 | `(,(raw (name (keyword parameter-group))) 29 | ,(unparse-parameter client (parameter parameter-group)))) 30 | 31 | (defmethod unparse-parameter-group 32 | (client (parameter-group implicit-parameter-group)) 33 | (loop for parameter in (parameters parameter-group) 34 | collect (unparse-parameter client parameter))) 35 | 36 | (defmethod unparse-parameter-group 37 | (client (parameter-group explicit-multi-parameter-group)) 38 | `(,(raw (name (keyword parameter-group))) 39 | ,@(loop for parameter in (parameters parameter-group) 40 | collect (unparse-parameter client parameter)))) 41 | 42 | (defmethod unparse-parameter-group 43 | (client (parameter-group key-parameter-group)) 44 | `(,(raw (name (keyword parameter-group))) 45 | ,@(loop for parameter in (parameters parameter-group) 46 | collect (unparse-parameter client parameter)) 47 | ,@(when (allow-other-keys parameter-group) '(&allow-other-keys)))) 48 | 49 | ;;; &aux parameters don't affect parsing errors, so we skip them. 50 | (defmethod unparse-parameter-group 51 | (client (parameter-group aux-parameter-group)) 52 | (declare (ignore client)) 53 | nil) 54 | 55 | ;;; 56 | 57 | (defmethod unparse-parameter (client (parameter simple-variable)) 58 | (declare (ignore client)) 59 | (raw (name parameter))) 60 | 61 | ;;; Since unparsing is basically used for error reports at runtime, 62 | ;;; the specializer is probably not relevant. 63 | (defmethod unparse-parameter (client (parameter specialized-required-parameter)) 64 | (declare (ignore client)) 65 | (raw (name parameter))) 66 | 67 | (defmethod unparse-parameter (client (parameter ordinary-optional-parameter)) 68 | (declare (ignore client)) 69 | (raw (name parameter))) 70 | 71 | (defmethod unparse-parameter 72 | (client (parameter generic-function-optional-parameter)) 73 | (declare (ignore client)) 74 | (raw (name parameter))) 75 | 76 | (defmethod unparse-parameter (client (parameter ordinary-key-parameter)) 77 | (declare (ignore client)) 78 | (let ((rname (raw (name parameter))) 79 | (rkeyword (raw (keyword parameter)))) 80 | (if (and (keywordp rkeyword) 81 | (string= (symbol-name rname) (symbol-name rkeyword))) 82 | ;; The keyword corresponds to the variable, so they don't 83 | ;; both need to be in the unparse. 84 | rname 85 | ;; The keyword was custom. 86 | `((,rkeyword ,rname))))) 87 | 88 | (defmethod unparse-parameter (client (parameter aux-parameter)) 89 | (declare (ignore client)) 90 | (raw (name parameter))) 91 | 92 | (defmethod unparse-parameter 93 | (client (parameter destructuring-optional-parameter)) 94 | (unparse-lambda-list client (name parameter))) 95 | 96 | (defmethod unparse-parameter (client (parameter destructuring-key-parameter)) 97 | `((,(raw (keyword parameter)) 98 | ,(unparse-lambda-list client (name parameter))))) 99 | 100 | (defmethod unparse-parameter (client (parameter destructuring-lambda-list)) 101 | (unparse-lambda-list client parameter)) 102 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This library is intended to solve the problem of source tracking for 2 | Common Lisp code. 3 | 4 | By "source tracking", we mean that code elements that have a known 5 | origin in the form of a position in a file or in an editor buffer are 6 | associated with some kind of information about this origin. 7 | 8 | Since the exact nature of such origin information depends on the 9 | Common Lisp implementation and the purpose of wanting to track that 10 | origin, we do not impose a particular structure of this information. 11 | Instead, we provide utilities for manipulating source code in the form 12 | of what we call concrete syntax trees (CSTs for short) that preserve 13 | this information about the origin. 14 | 15 | For example, we provide code utilities for canonicalizing 16 | declarations, parsing lambda lists, separating declarations and 17 | documentation strings and code bodies, checking whether a form is a 18 | proper list, etc. All these utilities manipulate the code in the form 19 | of a CST, and provide CSTs as a result of the manipulation that 20 | propagates the origin information as much as possible. 21 | 22 | In particular, we provide an "intelligent macroexpander". This 23 | function takes an original CST and the result of macroexpanding the 24 | RAW code version of that CST, and returns a new CST representing the 25 | expanded code in such a way that as much as possible of the origin 26 | information is preserved. 27 | -------------------------------------------------------------------------------- /Source-info/concrete-syntax-tree-source-info.asd: -------------------------------------------------------------------------------- 1 | (defsystem "concrete-syntax-tree-source-info" 2 | :serial t 3 | :components ((:file "packages") 4 | (:file "source-info"))) 5 | -------------------------------------------------------------------------------- /Source-info/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:concrete-syntax-tree-source-info 4 | (:nicknames #:cst-source-info) 5 | (:use #:common-lisp)) 6 | -------------------------------------------------------------------------------- /Source-info/source-info.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-source-info) 2 | 3 | ;;; This module is provided for convenience. It is not required in 4 | ;;; order for the rest of this library to work. 5 | 6 | (defclass source-info () ()) 7 | 8 | (defclass standard-source-info (source-info) 9 | (;; This slot contains some kind of document from which this source 10 | ;; code was read. It can be a file name, a string, an editor 11 | ;; buffer, or any other document that client code is able to 12 | ;; manipulate. 13 | (%document :initarg :document :reader document) 14 | ;; Lines in source code are numbered starting at 0. 15 | (%start-line-number :initarg :start-line-number :reader start-line-number) 16 | ;; This slot contains the number of lines that this source code 17 | ;; spans. 18 | (%height :initarg height :reader height) 19 | ;; Columns in source code are numbered starting at 0. 20 | (%start-column-number :initarg :start-column-number :reader start-column-number) 21 | ;; This slot contains a value that is one greater than the last 22 | ;; column of this source code, following the convention of similar 23 | ;; functionality in other parts of Common Lisp. 24 | (%end-column-number :initarg :end-column-number :reader end-column-number))) 25 | -------------------------------------------------------------------------------- /Test/cst-from-expression.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-test) 2 | 3 | (def-suite* :concrete-syntax-tree.cst-from-expression 4 | :in :concrete-syntax-tree) 5 | 6 | (test cst-from-expression.atoms-without-identity 7 | "Test that `cst-from-expression' always creates fresh CSTs for atoms 8 | that behave like values without identity." 9 | (flet ((test-atoms (atom) 10 | (let* ((expression `(,atom ,atom)) 11 | (cst (cst:cst-from-expression expression))) 12 | (is (not (eq (cst:first cst) (cst:second cst))))))) 13 | (test-atoms 1) 14 | (test-atoms #\c) 15 | ;; Symbols are different from numbers and characters, of course, 16 | ;; but distinct occurrences of a given symbol either in code or in 17 | ;; an s-expression are not typically treated as the same syntactic 18 | ;; object. 19 | (test-atoms :fo))) 20 | 21 | (defstruct atom-test-struct) 22 | 23 | (defclass atom-test-class () ()) 24 | 25 | (test cst-from-expression.atoms-with-identity 26 | "Test that `cst-from-expression' creates fresh CSTs or uses shared CSTs 27 | for atoms that have meaningful identities." 28 | (flet ((test-atoms (atom1 atom2) 29 | (let* ((expression `(,atom1 ,atom2 ,atom1)) 30 | (cst (cst:cst-from-expression expression))) 31 | (is (not (eq (cst:first cst) (cst:second cst)))) 32 | (is (eq (cst:first cst) (cst:third cst)))))) 33 | (test-atoms #P"foo" #P"bar") 34 | (test-atoms (make-atom-test-struct) (make-atom-test-struct)) 35 | (test-atoms (make-instance 'atom-test-class) 36 | (make-instance 'atom-test-class)))) 37 | 38 | (defun assert-equality (cst-root expression-root) 39 | (loop with tail = (list (cons cst-root expression-root)) 40 | for worklist = tail then (rest worklist) 41 | for (cst . expression) = (first worklist) 42 | while worklist 43 | if (cst:null cst) 44 | do (unless (null expression) 45 | (fail "~@" 47 | cst-root expression-root cst expression)) 48 | else 49 | do (unless (eql expression (cst:raw cst)) 50 | (fail "~@" 52 | cst-root expression-root cst (cst:raw cst) expression)) 53 | (when (cst:consp cst) 54 | (unless (consp expression) 55 | (fail "~@" 57 | cst-root expression-root cst expression)) 58 | (flet ((enqueue (item) 59 | (let ((cell (list item))) 60 | (setf (rest tail) cell 61 | tail cell)))) 62 | (enqueue (cons (cst:first cst) (car expression))) 63 | (enqueue (cons (cst:rest cst) (cdr expression))))))) 64 | 65 | (test cst-from-expression.random 66 | (let ((fiveam:*test-dribble* nil)) ; too much output otherwise 67 | (loop repeat 1000000 68 | for expression = (random-expression) 69 | for cst = (cst:cst-from-expression expression) 70 | do (assert-equality cst expression)))) 71 | 72 | (test cst-from-expression.circular 73 | (let* ((expression '#1=(1 #1#)) 74 | (cst (cst:cst-from-expression expression))) 75 | (is (eq expression (cst:raw cst))) 76 | (is (eq (first expression) (cst:raw (cst:first cst)))) 77 | (is (eq cst (cst:second cst))))) 78 | 79 | (test cst-from-expression.long-list 80 | (let* ((expression (make-long-list)) 81 | (cst (cst:cst-from-expression expression))) 82 | (assert-equality cst expression))) 83 | -------------------------------------------------------------------------------- /Test/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:concrete-syntax-tree-test 2 | (:use 3 | #:common-lisp) 4 | 5 | (:import-from #:fiveam 6 | #:def-suite 7 | #:def-suite* 8 | #:test 9 | #:is 10 | #:is-true 11 | #:fail) 12 | 13 | (:export 14 | #:run-tests)) 15 | 16 | (cl:in-package #:concrete-syntax-tree-test) 17 | 18 | (def-suite :concrete-syntax-tree) 19 | 20 | (defun run-tests () 21 | (fiveam:run! :concrete-syntax-tree)) 22 | -------------------------------------------------------------------------------- /Test/quasiquotation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-test) 2 | 3 | (def-suite* :concrete-syntax-tree.quasiquote 4 | :in :concrete-syntax-tree) 5 | 6 | (test quasiquotation.smoke 7 | (let* ((cst1 (cst:cst-from-expression 'a)) 8 | (cst2 (cst:cst-from-expression '(b c))) 9 | (source (gensym)) 10 | (qq (cst:quasiquote source 11 | (d (cst:unquote cst1) (cst:unquote-splicing cst2) 12 | (cst:unquote cst2) (e (f f) . g) 13 | (cst:unquote-splicing (cl:list cst1 cst1)) 14 | ((cst:unquote cst1) . (cst:unquote cst1)))))) 15 | (is (equal '(d a b c (b c) (e (f f) . g) a a (a . a)) (cst:raw qq))) 16 | (is (eq source (cst:source qq))) 17 | (is (eq cst1 (cst:second qq))) 18 | (is (eq cst2 (cst:fifth qq))) 19 | (is (eq cst1 (cst:first (cst:ninth qq)))) 20 | (is (eq cst1 (cst:rest (cst:ninth qq)))))) 21 | -------------------------------------------------------------------------------- /Test/random-expression.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-test) 2 | 3 | (defun random-expression () 4 | (labels ((aux (cons-probability nil-probability) 5 | (cond ((< (random 1d0) cons-probability) 6 | (cons (aux (* cons-probability 0.8) nil-probability) 7 | (aux (* cons-probability 0.8) (* 1.2 nil-probability)))) 8 | ((< (random 1d0) nil-probability) 9 | nil) 10 | ((< (random 1d0) 0.2) 11 | (make-symbol (string (code-char (+ 65 (random 10)))))) 12 | ((< (random 1d0) 0.3) 13 | (code-char (+ 97 (random 10)))) 14 | ((< (random 1d0) 0.4) 15 | (+ 100000000000000000000000 (random 10))) 16 | (t 17 | (make-array 2))))) 18 | (aux 0.9 0.2))) 19 | 20 | (defun make-long-list (&key (length 100000) (depth 3)) 21 | (labels ((iota (length) 22 | (loop for i below length collect i)) 23 | (make-expression (depth) 24 | (if (zerop depth) 25 | (cons (reverse (iota length)) (iota length)) 26 | (cons (make-expression (1- depth)) 27 | (make-expression (1- depth)))))) 28 | (make-expression depth))) 29 | -------------------------------------------------------------------------------- /Test/random-sources.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-test) 2 | 3 | ;;; Assign random unique symbols as source locations to every node in 4 | ;;; a concrete syntax tree. 5 | 6 | (defgeneric random-sources (cst)) 7 | 8 | (defmethod random-sources ((cst cst:atom-cst)) 9 | (reinitialize-instance cst :source (gensym)) 10 | cst) 11 | 12 | (defmethod random-sources ((cst cst:cons-cst)) 13 | (reinitialize-instance cst :source (gensym)) 14 | (random-sources (cst:first cst)) 15 | (random-sources (cst:rest cst)) 16 | cst) 17 | -------------------------------------------------------------------------------- /Test/reconstruct.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree-test) 2 | 3 | (def-suite* :concrete-syntax-tree.reconstruct 4 | :in :concrete-syntax-tree) 5 | 6 | (test reconstruct.smoke 7 | (let* ((expression-1 (cons 'a 'c)) 8 | (expression-2 (list 'b expression-1)) 9 | (cst (cst:cst-from-expression expression-1)) 10 | (reconstructed (cst:reconstruct nil expression-2 cst))) 11 | (is (eq cst (cst:first (cst:rest reconstructed)))))) 12 | 13 | (test reconstruct.circular 14 | (let* ((circular (cst:cons (make-instance 'cst:atom-cst :raw nil) 15 | (make-instance 'cst:atom-cst :raw nil))) 16 | (result (progn 17 | (setf (slot-value circular 'cst::%first) circular) 18 | (cst:reconstruct nil '#1=(#1#) circular)))) 19 | (is-true (typep result 'cst:cst)) 20 | (is (eq result (cst:first result))))) 21 | 22 | (test reconstruct.sharing.same-structure 23 | "Test the sharing-related behavior of `reconstruct' in case the 24 | structure of the CST is the same as the structure of the original 25 | expression." 26 | (let* ((expression '(#1=1 #1# #2=#\a #2# #3=#P"foo" #3#)) 27 | (cst (cst:cst-from-expression expression)) 28 | (result (cst:reconstruct nil expression cst))) 29 | ;; This test can't work if `cst-from-expression' behaves 30 | ;; unexpectedly. 31 | (assert (not (eq (cst:first cst) (cst:second cst)))) 32 | (assert (not (eq (cst:third cst) (cst:fourth cst)))) 33 | (assert (eq (cst:fifth cst) (cst:sixth cst))) 34 | ;; Since the structure matches, RESULT should use the 35 | ;; corresponding `atom-cst's in CST. 36 | #.`(progn 37 | ,@(loop for reader in '(cst:first cst:second cst:third 38 | cst:fourth cst:fifth cst:sixth) 39 | collect `(is (eq (,reader cst) (,reader result))))) 40 | ;; Distinct CSTs for numbers and characters, unique CSTs for other 41 | ;; atoms. 42 | (is (not (eq (cst:first result) (cst:second result)))) 43 | (is (not (eq (cst:third result) (cst:fourth result)))) 44 | (is (eq (cst:fifth result) (cst:sixth result))))) 45 | 46 | (test reconstruct.sharing.shuffled 47 | "Test the sharing-related behavior of `reconstruct' in case the CST 48 | contains the same atoms as the original expression but with the order 49 | permuted." 50 | (let* ((pathname #P"foo") 51 | (expression `(#1=1 #1# #2=#\a #2# ,pathname ,pathname)) 52 | (cst (cst:cst-from-expression expression)) 53 | (shuffled-expression `(#11=1 ,pathname #12=#\a #12# ,pathname #11#)) 54 | (result (cst:reconstruct nil shuffled-expression cst))) 55 | ;; For any atom, RESULT uses the last occurrence (according to the 56 | ;; traversal order) of a matching CST in EXPRESSION. 57 | (is (eq (cst:second cst) (cst:first result))) 58 | (is (eq (cst:second cst) (cst:sixth result))) 59 | (is (eq (cst:fourth cst) (cst:third result))) 60 | (is (eq (cst:fourth cst) (cst:fourth result))) 61 | (is (eq (cst:sixth cst) (cst:second result))) 62 | (is (eq (cst:sixth cst) (cst:fifth result))) 63 | ;; For things like numbers and characters, we can't really tell 64 | ;; whether occurrences in SHUFFLED-EXPRESSION refer to particular 65 | ;; occurrences in CST. 66 | (is (eq (cst:second result) (cst:fifth result))))) 67 | 68 | (test reconstruct.sharing.unrelated 69 | "Test the sharing-related behavior of `reconstruct' in case the CST has 70 | no relation to the original expression" 71 | (let* ((expression nil) 72 | (cst (cst:cst-from-expression expression)) 73 | (unrelated-expression '(#1=1 #1# #2=#\a #2# #3=#P"foo" #3#)) 74 | (result (cst:reconstruct nil unrelated-expression cst))) 75 | ;; Since none of the `atom-cst's in RESULT come from CST, we 76 | ;; expect distinct CSTs for numbers and characters, shared CSTs 77 | ;; for other atoms. 78 | (is (not (eq (cst:first result) (cst:second result)))) 79 | (is (not (eq (cst:third result) (cst:fourth result)))) 80 | (is (eq (cst:fifth result) (cst:sixth result))))) 81 | 82 | (test reconstruct.long-list.same-structure 83 | "Test `reconstruct' on a long list with a CST that has the same 84 | structure as the original expression." 85 | (let* ((expression (make-long-list)) 86 | (unrelated-expression (make-long-list)) 87 | (cst (cst:cst-from-expression expression)) 88 | (result (cst:reconstruct nil unrelated-expression cst))) 89 | (assert-equality result unrelated-expression))) 90 | 91 | (test reconstruct.long-list.unrelated 92 | "Test `reconstruct' on a long list with a CST that has no relation to 93 | the original expression." 94 | (let* ((expression (make-long-list)) 95 | (cst (cst:cst-from-expression expression)) 96 | (result (cst:reconstruct nil expression cst))) 97 | (assert-equality result expression))) 98 | -------------------------------------------------------------------------------- /bindings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;;; This code provides useful operations on bindings as used by LET 4 | ;;;; and LET*. The bindings are in the form of a CST. Recall that 5 | ;;;; such a binding can have three different shapes, namely VAR, 6 | ;;;; (VAR), or (VAR INIT-FORM). The last of these three shapes is 7 | ;;;; considered canonical. 8 | 9 | ;;; Check whether a binding is valid, i.e., has one of the three valid 10 | ;;; shapes. 11 | (defun valid-binding-p (binding-cst) 12 | (let ((raw (raw binding-cst))) 13 | (or (symbolp raw) 14 | (and (cl:consp raw) 15 | (symbolp (car raw)) 16 | (or (cl:null (cdr raw)) 17 | (and (cl:consp (cdr raw)) 18 | (cl:null (cddr raw)))))))) 19 | 20 | ;;; Check whether each binding in a list of bindings represented as a 21 | ;;; CST is valid. 22 | (defun valid-bindings-p (bindings-cst) 23 | (and (proper-list-p bindings-cst) 24 | (loop for rest = bindings-cst then (rest rest) 25 | until (null rest) 26 | always (valid-binding-p (first rest))))) 27 | 28 | ;;; Check whether a single binding in the form of a CST represents a 29 | ;;; canonical binding. It is assumed that the binding is valid as 30 | ;;; checked by VALID-BINDING-P. 31 | (defun canonical-binding-p (binding-cst) 32 | (= (length (raw binding-cst)) 2)) 33 | 34 | ;;; Canonicalize a single binding represented as a CST. It is assumed 35 | ;;; that the binding is valid, but we do not know whether the binding 36 | ;;; is already canonical. If it is canonical, we return it as is. If 37 | ;;; not, we return a canonicalized version of it. 38 | (defun canonicalize-binding (binding-cst) 39 | (if (canonical-binding-p binding-cst) 40 | binding-cst 41 | (if (atom binding-cst) 42 | (let ((raw (cl:list (raw binding-cst) nil))) 43 | (make-instance 'cons-cst 44 | :raw raw 45 | :source (source binding-cst) 46 | :first binding-cst 47 | :rest (make-instance 'cons-cst 48 | :raw (cdr raw) 49 | :first (make-instance 'atom-cst :raw nil) 50 | :rest (make-instance 'atom-cst :raw nil)))) 51 | (let ((raw (cl:list (car (raw binding-cst)) nil))) 52 | (make-instance 'cons-cst 53 | :raw raw 54 | :source (source binding-cst) 55 | :first (first binding-cst) 56 | :rest (make-instance 'cons-cst 57 | :raw (cdr raw) 58 | :first (make-instance 'atom-cst :raw nil) 59 | :rest (make-instance 'atom-cst :raw nil))))))) 60 | 61 | ;;; Check whether each binding in a list of bindings represented as a 62 | ;;; CST is canonical. It is assumed that the bindings have been 63 | ;;; checked for validity as reported by VALID-BINDINGS-P. 64 | (defun canonical-bindings-p (bindings-cst) 65 | (loop for rest = bindings-cst then (rest rest) 66 | until (null rest) 67 | always (canonical-binding-p (first rest)))) 68 | 69 | ;;; Canonicalize a list of bindings represented as a CST. If the list 70 | ;;; of bindings is already canonical, it is returned as is. Otherwise 71 | ;;; a new CST is constructed in which each binding has been 72 | ;;; canonicalized. It is assumed that the bindings have been checked 73 | ;;; for validity as reported by VALID-BINDINGS-P. 74 | (defun canonicalize-bindings (bindings-cst) 75 | (if (null bindings-cst) 76 | bindings-cst 77 | (let ((rest (canonicalize-bindings (rest bindings-cst)))) 78 | (if (and (eq rest (rest bindings-cst)) 79 | (canonical-binding-p (first bindings-cst))) 80 | bindings-cst 81 | (let ((new-first (canonicalize-binding (first bindings-cst)))) 82 | (make-instance 'cons-cst 83 | :raw (cl:cons (raw new-first) (raw rest)) 84 | :source (source bindings-cst) 85 | :first new-first 86 | :rest rest)))))) 87 | 88 | ;;; Given a list of bindings represented as a CST, return a list of 89 | ;;; the variables bound in those bindings, also as a CST. This 90 | ;;; function is useful for turning a LET form into a LAMBDA form. It 91 | ;;; is assumed that the list of bindings is canonical. 92 | (defun binding-variables (bindings-cst) 93 | (if (null bindings-cst) 94 | bindings-cst 95 | (let ((rest (binding-variables (rest bindings-cst)))) 96 | (make-instance 'cons-cst 97 | :raw (cl:cons (car (raw (first bindings-cst))) (raw rest)) 98 | :source nil 99 | :first (first (first bindings-cst)) 100 | :rest rest)))) 101 | 102 | ;;; Given a list of bindings represented as a CST, return a list of 103 | ;;; the initialization forms of those bindings, also as a CST. This 104 | ;;; function is useful for turning a LET form into a LAMBDA form. It 105 | ;;; is assumed that the list of bindings is canonical. 106 | (defun binding-init-forms (bindings-cst) 107 | (if (null bindings-cst) 108 | bindings-cst 109 | (let ((rest (binding-init-forms (rest bindings-cst)))) 110 | (make-instance 'cons-cst 111 | :raw (cl:cons (cadr (raw (first bindings-cst))) (raw rest)) 112 | :source nil 113 | :first (second (first bindings-cst)) 114 | :rest rest)))) 115 | 116 | ;;; LocalWords: canonicalized, canonicalize 117 | -------------------------------------------------------------------------------- /body.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod separate-ordinary-body ((body atom-cst)) 4 | (assert (null body)) 5 | (values '() (make-instance 'atom-cst :raw nil))) 6 | 7 | (defmethod separate-ordinary-body ((body cons-cst)) 8 | (loop with declarations = '() 9 | for remaining = body then (rest remaining) 10 | until (or (null remaining) 11 | (atom (first remaining)) 12 | (not (eq (raw (first (first remaining))) 'declare))) 13 | do (push (first remaining) declarations) 14 | finally (return (values (reverse declarations) remaining)))) 15 | 16 | (defmethod separate-function-body ((body atom-cst)) 17 | (assert (null body)) 18 | (values '() nil (make-instance 'atom-cst :raw nil))) 19 | 20 | (defmethod separate-function-body ((body cons-cst)) 21 | (loop with declarations = '() 22 | with documentation = nil 23 | for remaining = body then (rest remaining) 24 | until (or (null remaining) 25 | (and (atom (first remaining)) 26 | (not (stringp (raw (first remaining))))) 27 | (and (stringp (raw (first remaining))) 28 | (or (not (cl:null documentation)) 29 | ;; if a string is the last form, it's not a docstring 30 | (null (rest remaining)))) 31 | (and (consp (first remaining)) 32 | (not (eq (raw (first (first remaining))) 'declare)))) 33 | do (if (stringp (raw (first remaining))) 34 | (setf documentation (first remaining)) 35 | (push (first remaining) declarations)) 36 | finally (return (values (reverse declarations) 37 | documentation 38 | remaining)))) 39 | -------------------------------------------------------------------------------- /concrete-syntax-tree.asd: -------------------------------------------------------------------------------- 1 | (defsystem "concrete-syntax-tree" 2 | :description "Library for parsing Common Lisp code into a concrete syntax tree." 3 | :license "BSD" ; See LICENSE file for details 4 | :author "Robert Strandh " 5 | 6 | :version (:read-file-form "version-string.sexp") 7 | :depends-on ("acclimation") 8 | 9 | :components ((:module "base" 10 | :pathname "." 11 | :serial t 12 | :components ((:file "packages") 13 | (:file "generic-functions") 14 | (:file "conditions") 15 | (:file "utilities") 16 | (:file "cst") 17 | (:file "cons-cst") 18 | (:file "listify") 19 | (:file "cstify") 20 | (:file "cst-from-expression") 21 | (:file "quasiquotation") 22 | (:file "reconstruct") 23 | (:file "declarations") 24 | (:file "body") 25 | (:file "list-structure") 26 | (:file "bindings") 27 | 28 | (:file "condition-reporters-english")))) 29 | 30 | :in-order-to ((test-op (test-op "concrete-syntax-tree/test")))) 31 | 32 | (defsystem "concrete-syntax-tree/test" 33 | :depends-on ("fiveam" 34 | "concrete-syntax-tree") 35 | :pathname "Test" 36 | :serial t 37 | :components ((:file "packages") 38 | (:file "random-expression") 39 | (:file "cst-from-expression") 40 | (:file "quasiquotation") 41 | (:file "random-sources") 42 | (:file "reconstruct")) 43 | :perform (test-op (operation component) 44 | (when (and (not (uiop:symbol-call '#:concrete-syntax-tree-test 45 | '#:run-tests)) 46 | (boundp 'cl-user::*result*)) 47 | (setf (symbol-value 'cl-user::*result*) nil)))) 48 | -------------------------------------------------------------------------------- /condition-reporters-english.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod acclimation:report-condition 4 | ((condition null-cst-required) stream (language acclimation:english)) 5 | (format stream "~@" 7 | (cst condition) 'null)) 8 | 9 | (defmethod acclimation:report-condition 10 | ((condition cons-cst-required) stream (language acclimation:english)) 11 | (format stream "~@" 12 | (cst condition) 'cons-cst)) 13 | 14 | (defmethod acclimation:report-condition 15 | ((condition unquote-splicing-in-dotted-list) stream 16 | (language acclimation:english)) 17 | (format stream "Splicing unquote at end of list (like a . ,@b).")) 18 | 19 | (defmethod acclimation:report-condition 20 | ((condition unquote-splicing-at-top) stream (language acclimation:english)) 21 | (format stream "Splicing unquote as quasiquotation form (like `,@foo).")) 22 | -------------------------------------------------------------------------------- /conditions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (define-condition cst-error (error acclimation:condition) 4 | ()) 5 | 6 | ;;; This condition is signaled whenever a CST instance satisfying NULL 7 | ;;; was required, but something else was given. 8 | (define-condition null-cst-required (cst-error) 9 | ((%cst :initarg :cst :reader cst))) 10 | 11 | ;;; This condition is signaled whenever an instance of the class 12 | ;;; CONS-CST was required, but something else was given. 13 | (define-condition cons-cst-required (cst-error) 14 | ((%cst :initarg :cst :reader cst))) 15 | 16 | (define-condition unquote-error (error) ()) 17 | 18 | (define-condition unquote-splicing-in-dotted-list (unquote-error) ()) 19 | (define-condition unquote-splicing-at-top (unquote-error) ()) 20 | -------------------------------------------------------------------------------- /cons-cst.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass cons-cst (cst) 4 | (;; This slot contains a CST that represents the CAR of the 5 | ;; corresponding expression. 6 | (%first :initform nil :initarg :first :reader first) 7 | ;; This slot contains a CST that represents the CDR of the 8 | ;; corresponding expression. 9 | (%rest :initform nil :initarg :rest :reader rest))) 10 | 11 | (defmethod consp ((cst cons-cst)) 12 | (declare (ignorable cst)) 13 | t) 14 | 15 | (defgeneric cons (first rest &key source)) 16 | 17 | (defun raw-or-nil (cst) 18 | (raw cst)) 19 | 20 | (defmethod cons (first rest &key source) 21 | (make-instance 'cons-cst 22 | :raw (cl:cons (raw-or-nil first) (raw-or-nil rest)) 23 | :source source 24 | :first first 25 | :rest rest)) 26 | 27 | (defun list (&rest csts) 28 | (loop for result = (make-instance 'atom-cst :raw nil) then (cons cst result) 29 | for cst in (reverse csts) 30 | finally (return result))) 31 | 32 | (defgeneric nthrest (n cst) 33 | (:method (n (cst cons-cst)) 34 | (loop for tail = cst then (rest tail) 35 | repeat n 36 | finally (return tail)))) 37 | 38 | (defgeneric nth (n cst) 39 | (:method (n (cst cons-cst)) 40 | (first (nthrest n cst)))) 41 | 42 | (defgeneric second (cst) 43 | (:method ((cst cons-cst)) 44 | (nth 1 cst))) 45 | 46 | (defgeneric third (cst) 47 | (:method ((cst cons-cst)) 48 | (nth 2 cst))) 49 | 50 | (defgeneric fourth (cst) 51 | (:method ((cst cons-cst)) 52 | (nth 3 cst))) 53 | 54 | (defgeneric fifth (cst) 55 | (:method ((cst cons-cst)) 56 | (nth 4 cst))) 57 | 58 | (defgeneric sixth (cst) 59 | (:method ((cst cons-cst)) 60 | (nth 5 cst))) 61 | 62 | (defgeneric seventh (cst) 63 | (:method ((cst cons-cst)) 64 | (nth 6 cst))) 65 | 66 | (defgeneric eighth (cst) 67 | (:method ((cst cons-cst)) 68 | (nth 7 cst))) 69 | 70 | (defgeneric ninth (cst) 71 | (:method ((cst cons-cst)) 72 | (nth 8 cst))) 73 | 74 | (defgeneric tenth (cst) 75 | (:method ((cst cons-cst)) 76 | (nth 9 cst))) 77 | -------------------------------------------------------------------------------- /cst-from-expression.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; Given EXPRESSION and a (possibly empty) hash-table mapping 4 | ;;; expressions to CSTs, build a CST from EXPRESSION in such a way 5 | ;;; that if a (sub-)expression is encountered that has a mapping in 6 | ;;; the table, then the corresponding CST in the table is used. 7 | (defun cst-from-expression (expression &key source 8 | (expression->cst 9 | (make-hash-table :test #'eq))) 10 | ;; This function uses WITH-BOUNDED-RECURSION since, depending on the 11 | ;; structure of EXPRESSION, TRAVERSE calls could otherwise nest more 12 | ;; deeply than supported by the implementation. 13 | (let ((stack '())) 14 | (declare (type cl:list stack)) 15 | (with-bounded-recursion (enqueue do-work worklist) 16 | (labels ((finalize-cons-cst (cst first rest) 17 | ;; Should we make this function user-extensible or 18 | ;; let the user control the class of the created CSTs 19 | ;; in some way, we would probably need something like 20 | ;; 21 | ;; (reinitialize-instance cst :first (traverse car depth+1) 22 | ;; :rest (traverse cdr depth+1)) 23 | ;; 24 | ;; But setting the slots directly reduces the 25 | ;; overall(!) runtime of a semi-realistic benchmark 26 | ;; to around 30 %. 27 | (setf (slot-value cst '%first) first 28 | (slot-value cst '%rest) rest) 29 | cst) 30 | (make-cons-cst (expression depth) 31 | (declare (type (integer 0 #.+recursion-depth-limit+) depth)) 32 | (let ((car (car expression)) 33 | (cdr (cdr expression)) 34 | (cst (make-instance 'cons-cst :raw expression 35 | :source source))) 36 | (setf (gethash expression expression->cst) cst) 37 | (cond ((< depth +recursion-depth-limit+) 38 | (let ((depth+1 (1+ depth))) 39 | (finalize-cons-cst 40 | cst (traverse car depth+1) (traverse cdr depth+1)))) 41 | (t 42 | ;; First and second work items: restart 43 | ;; recursion for CAR and CDR and push 44 | ;; results onto STACK. 45 | (enqueue car) 46 | (enqueue cdr) 47 | ;; Third work item: pop results for CDR and 48 | ;; CAR, update CST and push result onto 49 | ;; STACK. 50 | (enqueue 51 | (lambda () 52 | (assert (>= (length stack) 2)) 53 | (let ((rest (pop stack)) 54 | (first (pop stack))) 55 | (finalize-cons-cst cst first rest)))))) 56 | ;; Return CST now so it can be added to its parent 57 | ;; even though there may be a work item to update 58 | ;; CST later. 59 | cst)) 60 | (traverse (expression depth) 61 | (multiple-value-bind (existing-cst foundp) 62 | (gethash expression expression->cst) 63 | (cond (foundp 64 | existing-cst) 65 | ((cl:consp expression) 66 | (make-cons-cst expression depth)) 67 | (t 68 | ;; The was no existing CST for EXPRESSION, 69 | ;; so create one. But enter the new CST 70 | ;; into EXPRESSION->CST only if its identity 71 | ;; matters. 72 | (let ((cst (make-instance 'atom-cst :raw expression 73 | :source source))) 74 | (if (typep expression '(or number 75 | character 76 | symbol)) 77 | cst 78 | (setf (gethash expression expression->cst) cst)))))))) 79 | (declare (inline finalize-cons-cst)) 80 | (let ((cst (traverse expression 0))) 81 | (cond ((cl:null worklist) 82 | ;; For small inputs, WORKLIST is not populated and 83 | ;; STACK is not needed either. 84 | cst) 85 | (t 86 | ;; Since WORKLIST has been populated, we have use 87 | ;; STACK as well. We optimistically did not push CST 88 | ;; onto STACK. Do that now, then process the queued 89 | ;; work items. 90 | (push cst stack) 91 | (do-work (work-item) 92 | (if (functionp work-item) 93 | (funcall work-item) 94 | (push (traverse work-item 0) stack))) 95 | ;; After all work is done, the stack contents must 96 | ;; have been reduced to a single element. 97 | (assert (= (length stack) 1)) 98 | (cl:first stack)))))))) 99 | -------------------------------------------------------------------------------- /cst.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defclass cst () 4 | (;; This slot contains client-supplied information about the origin 5 | ;; of this CST. 6 | (%source :initform nil :initarg :source :accessor source) 7 | ;; This slot contains the raw expression that this CST represents. 8 | (%raw :initarg :raw :reader raw))) 9 | 10 | (defmethod print-object ((object cst) stream) 11 | (print-unreadable-object (object stream :type t :identity t) 12 | (format stream "raw: ~s" (raw object)))) 13 | 14 | (defmethod null ((cst cst)) 15 | (declare (ignorable cst)) 16 | nil) 17 | 18 | (defmethod atom ((cst cst)) 19 | (declare (ignorable cst)) 20 | nil) 21 | 22 | (defmethod consp ((cst cst)) 23 | (declare (ignorable cst)) 24 | nil) 25 | 26 | (defmethod first (cst) 27 | (error 'cons-cst-required 28 | :cst cst)) 29 | 30 | (defmethod rest (cst) 31 | (error 'cons-cst-required 32 | :cst cst)) 33 | 34 | ;;; This class is used to represent expressions that are atoms. It is 35 | ;;; not used to represent the end of a chain of CSTs. 36 | (defclass atom-cst (cst) 37 | ()) 38 | 39 | (defmethod atom ((cst atom-cst)) 40 | (declare (ignorable cst)) 41 | t) 42 | 43 | (defmethod null ((cst atom-cst)) 44 | (cl:null (raw cst))) 45 | -------------------------------------------------------------------------------- /cstify.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod cstify ((list cl:null) &key source) 4 | (make-instance 'atom-cst :raw nil :source source)) 5 | 6 | (defmethod cstify ((list cl:cons) &key source) 7 | (let ((rest (cstify (cdr list)))) 8 | (make-instance 'cons-cst 9 | :first (car list) 10 | :rest rest 11 | :source source 12 | :raw (cl:cons (raw (car list)) (raw rest))))) 13 | -------------------------------------------------------------------------------- /declarations.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; This function has four parameters. The first parameter identifies 4 | ;;; the client system. We do not specialize on that parameter, but 5 | ;;; client code can customize the behavior by overriding or extending 6 | ;;; the behavior of the methods defined here. The second parameter is 7 | ;;; the declaration identifier. It is a symbol that identifies what 8 | ;;; kind of declaration we are dealing with. The third parameter is 9 | ;;; the CST version of the declaration identifier. The fourth 10 | ;;; parameter is the declaration data, i.e. whatever follows the 11 | ;;; declaration identifier in a declaration. This function returns an 12 | ;;; ordinary Common Lisp list of CSTs. Each CST represents a list of 13 | ;;; the declaration identifier given as an argument, and a single item 14 | ;;; in the declaration data. 15 | (defgeneric canonicalize-declaration-specifier 16 | (system declaration-identifier declaration-identifier-cst declaration-data)) 17 | 18 | (defmethod canonicalize-declaration-specifier 19 | (system declaration-identifier declaration-identifier-cst declaration-data) 20 | (declare (ignore declaration-identifier)) 21 | ;; Treat as a type declaration. 22 | ;; Declarations from PROCLAIM DECLARATION will have already been filtered out 23 | ;; in CANONICALIZE-DECLARATION-SPECIFIERS, below. 24 | (canonicalize-declaration-specifier 25 | system 'type 26 | (make-instance 'atom-cst :raw 'type :source (source declaration-identifier-cst)) 27 | (cons declaration-identifier-cst declaration-data))) 28 | 29 | ;;; Given a PREFIX P and a list of ITEMS, say (I1 I2 ... In), return a 30 | ;;; list of the items prefixed with P, i.e. ((P I1) (P I2) ... (P 31 | ;;; In)). The twist is that the list of items is represented in the 32 | ;;; form of a concrete syntax tree. 33 | (defun map-prefix (prefix items) 34 | (loop for remaining = items then (rest remaining) 35 | until (null remaining) 36 | collect (list prefix (first remaining)))) 37 | 38 | (defmacro define-simple-canonicalize-method (declaration-identifier) 39 | `(defmethod canonicalize-declaration-specifier 40 | (system 41 | (declaration-identifier (eql ',declaration-identifier)) 42 | declaration-identifier-cst 43 | declaration-data) 44 | (declare (ignore system)) 45 | (map-prefix declaration-identifier-cst declaration-data))) 46 | 47 | (progn 48 | . #.(loop for declaration-identifier in 49 | '(declaration dynamic-extent ignore ignorable 50 | inline notinline optimize special) 51 | collect `(define-simple-canonicalize-method ,declaration-identifier))) 52 | 53 | (defmethod canonicalize-declaration-specifier 54 | (system 55 | (declaration-identifier (eql 'ftype)) 56 | declaration-identifier-cst 57 | declaration-data) 58 | (declare (ignore system)) 59 | (loop with type = (first declaration-data) 60 | for remaining = (rest declaration-data) then (rest remaining) 61 | until (null remaining) 62 | collect (list declaration-identifier-cst type (first remaining)))) 63 | 64 | (defmethod canonicalize-declaration-specifier 65 | (system 66 | (declaration-identifier (eql 'type)) 67 | declaration-identifier-cst 68 | declaration-data) 69 | (declare (ignore system)) 70 | (loop with type = (first declaration-data) 71 | for remaining = (rest declaration-data) then (rest remaining) 72 | until (null remaining) 73 | collect (list declaration-identifier-cst type (first remaining)))) 74 | 75 | ;;; IGNORE-DECLS is a list of symbols. These symbols are declaration identifiers 76 | ;;; that CST should ignore, i.e., these declarations will be canonicalized as NIL. 77 | (defun canonicalize-declaration-specifiers (system ignore-decls declaration-specifiers) 78 | (reduce #'append 79 | (mapcar (lambda (specifier) 80 | (let* ((declaration-identifier-cst (first specifier)) 81 | (declaration-data-cst (rest specifier)) 82 | (declaration-identifier (raw declaration-identifier-cst))) 83 | ;; Filter out ignored declarations. 84 | ;; (Intended for PROCLAIM DECLARATION.) 85 | (if (member declaration-identifier ignore-decls :test #'eq) 86 | nil 87 | (canonicalize-declaration-specifier 88 | system 89 | declaration-identifier 90 | declaration-identifier-cst 91 | declaration-data-cst)))) 92 | declaration-specifiers) 93 | :from-end t)) 94 | 95 | ;;; Given an ordinary Common Lisp list of declarations, each 96 | ;;; declaration being represented as a CST, return an ordinary Common 97 | ;;; Lisp list of all the declaration specifiers. The raw form of a 98 | ;;; CST of the input is: 99 | ;;; 100 | ;;; (DECLARE ... ) 101 | (defun declaration-specifiers (declaration-csts) 102 | (loop for declaration-cst in declaration-csts 103 | append (loop for cst = (rest declaration-cst) then (rest cst) 104 | until (null cst) 105 | collect (first cst)))) 106 | 107 | ;;; Given an ordinary Common Lisp list of declarations, each being 108 | ;;; represented as a CST, return a list of canonicalized declaration 109 | ;;; specifiers of all the declarations. 110 | (defun canonicalize-declarations (system ignore-decls declarations) 111 | (canonicalize-declaration-specifiers 112 | system ignore-decls (declaration-specifiers declarations))) 113 | -------------------------------------------------------------------------------- /generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; Given a CST, return the location of the source for it. The source 4 | ;;; location is represented by a client-defined object. 5 | (defgeneric source (cst)) 6 | 7 | ;;; Return true if and only if CST is an instance of NULL-CST. 8 | (defgeneric null (cst)) 9 | 10 | ;;; Return true if and only if CST represents an atomic expression. 11 | (defgeneric atom (cst)) 12 | 13 | ;;; Return true if and only if CST represents a CONS expression. 14 | (defgeneric consp (cst)) 15 | 16 | ;;; Given a CST, return the underlying Common Lisp expression. 17 | (defgeneric raw (cst)) 18 | 19 | ;;; Given a CONS-CST, return the FIRST of that CST. If some other CST 20 | ;;; type is given, including an ATOM-CST representing NIL, then an 21 | ;;; error is signaled. 22 | (defgeneric first (cons-cst)) 23 | 24 | ;;; Given a CONS-CST, return the REST of that CST. If some other CST 25 | ;;; type is given, including an ATOM-CST representing NIL, then an 26 | ;;; error is signaled. 27 | (defgeneric rest (cons-cst)) 28 | 29 | ;;; Given a CST representing a proper list, return an ordinary Common 30 | ;;; Lisp list of the CSTs that are elements of that CST. 31 | (defgeneric listify (cst)) 32 | 33 | ;;; Given an ordinary proper Common Lisp list of CSTs, return a CST, 34 | ;;; the elements of which are the CSTs of the input. 35 | (defgeneric cstify (list &key source)) 36 | 37 | ;;; Given a body in the form of a CST that may contain declarations 38 | ;;; but not a documentation string, return two values 39 | ;;; 1) an ordinary Common Lisp list of CST instances representing the 40 | ;;; declarations 41 | ;;; 2) a CST instance representing the forms in the body. 42 | ;;; It is assumed that the input has already been determined to be a 43 | ;;; proper list represented as a CST. 44 | (defgeneric separate-ordinary-body (body-cst)) 45 | 46 | ;;; Given a body in the form of a CST that may contain both 47 | ;;; declarations and a documentation string, return three values 48 | ;;; 1) an ordinary Common Lisp list of CST instances representing the 49 | ;;; declarations 50 | ;;; 2) an ATOM-CST representing the documentation string (or NIL if no 51 | ;;; documentation string is present in the body) 52 | ;;; 3) a CST instance representing the forms in the body. 53 | ;;; It is assumed that the input has already been determined to be a 54 | ;;; proper list represented as a CST. 55 | (defgeneric separate-function-body (body-cst)) 56 | 57 | ;;; Given a CST and an expression that is presumably some transformed 58 | ;;; version of the raw version of the CST, create a new CST that tries 59 | ;;; to reuse as much as possible of the given CST, so as to preserve 60 | ;;; source information. 61 | (defgeneric reconstruct (client expression cst &key default-source)) 62 | -------------------------------------------------------------------------------- /list-structure.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; For any CST, determine its structure as represented by successive 4 | ;;; REST values. Return the result as two values the first value 5 | ;;; contains the number of unique CONS-CSTs in the chain, and the 6 | ;;; second value is one of the keywords :proper, :dotted, and 7 | ;;; :circular. For an ATOM-CST, 0 and :dotted is returned. 8 | ;;; 9 | ;;; This function is useful for processing code because lists 10 | ;;; representing code are not often very long, so the method used is 11 | ;;; fast and appropriate, and because we often need to check that such 12 | ;;; lists are proper, but the simple method would go into an infinite 13 | ;;; computation if the list is circular, whereas we would like to give 14 | ;;; an error message in that case. 15 | (defun list-structure (cst) 16 | ;; First we attempt to just traverse the CST as usual, assuming that 17 | ;; it is fairly short. If we reach the end, then that's great, and 18 | ;; we return the result. 19 | (loop for remaining = cst then (rest remaining) 20 | for count from 0 to 100 21 | while (consp remaining) 22 | finally (cond ((null remaining) 23 | (return-from list-structure 24 | (values count :proper))) 25 | ((atom remaining) 26 | (return-from list-structure 27 | (values count :dotted))) 28 | (t nil))) 29 | ;; Come here if the list has more than a few CONS-CSTs. We traverse 30 | ;; it again, this time entering each CONS-CST in a hash table. Stop 31 | ;; when we reach the end of the chain, or when we see the same 32 | ;; CONS-CST twice. 33 | (let ((table (make-hash-table :test #'eq))) 34 | (loop for remaining = cst then (rest remaining) 35 | while (consp remaining) 36 | until (gethash remaining table) 37 | do (setf (gethash remaining table) t) 38 | finally (return (values (hash-table-count table) 39 | (cond ((null remaining) :proper) 40 | ((atom remaining) :dotted) 41 | (t :circular))))))) 42 | 43 | (defun proper-list-p (cst) 44 | (eq (nth-value 1 (list-structure cst)) :proper)) 45 | -------------------------------------------------------------------------------- /listify.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defmethod listify ((cst atom-cst)) 4 | (raw cst)) 5 | 6 | (defmethod listify ((cst cons-cst)) 7 | (cl:cons (first cst) (listify (rest cst)))) 8 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:concrete-syntax-tree 2 | (:nicknames #:cst) 3 | (:use #:common-lisp) 4 | (:shadow #:first 5 | #:second 6 | #:third 7 | #:fourth 8 | #:fifth 9 | #:sixth 10 | #:seventh 11 | #:eighth 12 | #:ninth 13 | #:tenth 14 | #:nth 15 | #:rest 16 | #:atom 17 | #:consp 18 | #:cons 19 | #:list 20 | #:null 21 | #:keyword) 22 | ;; Conditions 23 | (:export #:null-cst-required 24 | #:cons-cst-required 25 | 26 | #:structure-mismatch-error 27 | #:pattern 28 | #:whole-cst 29 | #:null-structure-mismatch-error 30 | #:cons-structure-mismatch-error) 31 | (:export #:cst 32 | #:cons-cst 33 | #:atom-cst 34 | #:source 35 | #:first 36 | #:second 37 | #:third 38 | #:fourth 39 | #:fifth 40 | #:sixth 41 | #:seventh 42 | #:eighth 43 | #:ninth 44 | #:tenth 45 | #:nthrest 46 | #:nth 47 | #:rest 48 | #:atom 49 | #:consp 50 | #:cons 51 | #:list 52 | #:null 53 | #:raw 54 | #:listify 55 | #:cstify 56 | #:separate-ordinary-body 57 | #:separate-function-body 58 | #:list-structure 59 | #:proper-list-p 60 | #:cst-from-expression 61 | #:canonicalize-declaration-specifier 62 | #:canonicalize-declaration-specifiers 63 | #:canonicalize-declarations 64 | #:declaration-specifiers 65 | #:reconstruct 66 | #:parser 67 | #:parse 68 | #:grammar-symbol 69 | #:parameter-group 70 | #:parameter-group-varargs-p 71 | #:singleton-parameter-group-mixin 72 | #:multi-parameter-group-mixin 73 | #:implicit-parameter-group 74 | #:explicit-parameter-group 75 | #:explicit-multi-parameter-group 76 | #:ordinary-required-parameter-group 77 | #:optional-parameter-group 78 | #:ordinary-optional-parameter-group 79 | #:key-parameter-group 80 | #:ordinary-key-parameter-group 81 | #:generic-function-key-parameter-group 82 | #:aux-parameter-group 83 | #:generic-function-optional-parameter-group 84 | #:specialized-required-parameter-group 85 | #:destructuring-required-parameter-group 86 | #:singleton-parameter-group 87 | #:destructuring-optional-parameter-group 88 | #:destructuring-key-parameter-group 89 | #:ordinary-rest-parameter-group 90 | #:destructuring-rest-parameter-group 91 | #:environment-parameter-group 92 | #:ordinary-whole-parameter-group 93 | #:destructuring-whole-parameter-group 94 | #:parameter 95 | #:parameters 96 | #:children 97 | #:keyword 98 | #:allow-other-keys 99 | #:simple-variable 100 | #:name 101 | #:ordinary-optional-parameter 102 | #:ordinary-key-parameter 103 | #:form 104 | #:supplied-p 105 | #:generic-function-key-parameter 106 | #:aux-parameter 107 | #:generic-function-optional-parameter 108 | #:specialized-required-parameter 109 | #:specializer 110 | #:destructuring-parameter 111 | #:destructuring-optional-parameter 112 | #:destructuring-key-parameter 113 | #:lambda-list-keyword 114 | #:keyword-optional 115 | #:keyword-rest 116 | #:keyword-body 117 | #:keyword-key 118 | #:keyword-allow-other-keys 119 | #:keyword-aux 120 | #:keyword-environment 121 | #:keyword-whole 122 | #:ordinary-lambda-list 123 | #:generic-function-lambda-list 124 | #:specialized-lambda-list 125 | #:defsetf-lambda-list 126 | #:define-modify-macro-lambda-list 127 | #:define-method-combination-lambda-list 128 | #:destructuring-lambda-list 129 | #:macro-lambda-list 130 | #:parse-ordinary-lambda-list 131 | #:parse-generic-function-lambda-list 132 | #:parse-specialized-lambda-list 133 | #:parse-defsetf-lambda-list 134 | #:parse-define-modify-macro-lambda-list 135 | #:parse-define-method-combination-lambda-list 136 | #:parse-destructuring-lambda-list 137 | #:parse-macro-lambda-list 138 | #:unparse-lambda-list 139 | #:unparse-parameter-group #:unparse-parameter 140 | #:target 141 | #:*ordinary-required-parameter-group* 142 | #:*ordinary-optional-parameter-group* 143 | #:*ordinary-rest-parameter-group* 144 | #:*ordinary-key-parameter-group* 145 | #:*aux-parameter-group* 146 | #:*ordinary-lambda-list* 147 | #:*generic-function-optional-parameter-group* 148 | #:*generic-function-key-parameter-group* 149 | #:*generic-function-lambda-list* 150 | #:*specialized-required-parameter-group* 151 | #:*specialized-lambda-list* 152 | #:*environment-parameter-group* 153 | #:*defsetf-lambda-list* 154 | #:*define-modify-macro-lambda-list* 155 | #:*whole-parameter-group* 156 | #:*define-method-combination-lambda-list* 157 | #:*destructuring-required-parameter-group* 158 | #:*destructuring-optional-parameter-group* 159 | #:*destructuring-key-parameter-group* 160 | #:*destructuring-rest-parameter-group* 161 | #:*destructuring-lambda-list* 162 | #:*macro-lambda-list* 163 | #:*standard-grammar* 164 | #:*ordinary-lambda-list-grammar* 165 | #:*generic-function-lambda-list-grammar* 166 | #:*specialized-lambda-list-grammar* 167 | #:*defsetf-lambda-list-grammar* 168 | #:*define-modify-macro-lambda-list-grammar* 169 | #:*define-method-combination-lambda-list-grammar* 170 | #:*destructuring-lambda-list-grammar* 171 | #:*macro-lambda-list-grammar* 172 | #:destructuring-lambda-list-bindings 173 | #:parameter-groups-bindings 174 | #:aux-parameter-bindings 175 | #:aux-parameters-bindings 176 | #:key-parameter-bindings 177 | #:key-parameters-bindings 178 | #:rest-parameter-bindings 179 | #:optional-parameter-bindings 180 | #:optional-parameters-bindings 181 | #:required-parameter-bindings 182 | #:required-parameters-bindings 183 | #:whole-parameter-bindings 184 | #:too-many-arguments-error #:too-few-arguments-error 185 | #:odd-keywords-error #:unknown-keywords-error 186 | #:parse-macro 187 | #:db 188 | #:valid-binding-p 189 | #:valid-bindings-p 190 | #:canonical-binding-p 191 | #:canonical-bindings-p 192 | #:canonicalize-binding 193 | #:canonicalize-bindings 194 | #:binding-variables 195 | #:binding-init-forms 196 | #:define-keyword-scanner-action 197 | #:? 198 | #:<- 199 | #:lambda-list-keyword 200 | #:lambda-list-type) 201 | (:export #:quasiquote #:unquote #:unquote-splicing 202 | #:unquote-error 203 | #:unquote-splicing-in-dotted-list #:unquote-splicing-at-top)) 204 | -------------------------------------------------------------------------------- /quasiquotation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;;; The QUASIQUOTE operator allows concrete syntax trees to be constructed in 4 | ;;;; a manner analogous to list quasiquotation (backquote). 5 | ;;;; The syntax is (QUASIQUOTE source template), where 6 | ;;;; template := atom 7 | ;;;; | (UNQUOTE form-yielding-cst) 8 | ;;;; | (template . template) 9 | ;;;; | ((UNQUOTE-SPLICING form-yielding-list-cst-or-list) 10 | ;;;; . template) 11 | ;;;; Unquotation means the CST yielded by a form will be inserted. 12 | ;;;; Splicing unquotation accepts both list CSTs 13 | ;;;; (i.e. CSTs suitable for LISTIFY) and lists of CSTs. 14 | ;;;; Atoms are made into ATOM-CSTs. 15 | ;;;; All CSTs created by quasiquotation will have the given source (evaluated) 16 | ;;;; as their source. 17 | ;;;; Note that unlike CL quasiquotation, vector templates are not allowed, as 18 | ;;;; there are no vector CSTs. Vectors in templates will be treated as atoms 19 | ;;;; and wrapped in CSTs without processing of the elements. 20 | ;;;; There is no equivalent to ,. 21 | 22 | (defun %quote (source atom) (make-instance 'atom-cst :raw atom :source source)) 23 | 24 | (defun %append2 (source x y) 25 | (etypecase x 26 | (atom-cst y) ; could check that X is really NIL 27 | (cons-cst (cons (first x) (%append2 source (rest x) y) :source source)) 28 | (cl:null y) 29 | (cl:cons 30 | (cons (cl:first x) (%append2 source (cl:rest x) y) :source source)))) 31 | 32 | (defun %append (source &rest list-csts-and-lists) 33 | (cond ((cl:null list-csts-and-lists) (%quote source nil)) 34 | ((cl:null (cl:rest list-csts-and-lists)) 35 | (cl:first list-csts-and-lists)) 36 | (t (%append2 source (cl:first list-csts-and-lists) 37 | (apply #'%append source (cl:rest list-csts-and-lists)))))) 38 | 39 | (defun transform (sourcef form) 40 | (typecase form 41 | ;; We can use CL:LIST instead of building a CST because TRANSFORM always 42 | ;; returns a form used as a non-final argument to %APPEND. 43 | (cl:atom `(cl:list (%quote ,sourcef ',form))) 44 | ((cl:cons (eql unquote)) `(cl:list ,(cl:second form))) 45 | ((cl:cons (eql unquote-splicing)) (cl:second form)) 46 | (t `(cl:list ,(appender sourcef form))))) 47 | 48 | (defun transform-compound (sourcef object) 49 | (labels ((rec (object) 50 | (typecase object 51 | ((cl:cons t cl:atom) ; (a . b) 52 | (cl:list (transform sourcef (cl:car object)) 53 | `(%quote ,sourcef ',(cl:cdr object)))) 54 | ((cl:cons t (cl:cons (eql unquote))) ; (a . ,b) 55 | (cl:list (transform sourcef (cl:car object)) 56 | (cl:second (cl:cdr object)))) 57 | ((cl:cons t (cl:cons (eql unquote-splicing))) ; (a . ,@b) 58 | (error 'unquote-splicing-in-dotted-list)) 59 | (t (cl:list* (transform sourcef (cl:car object)) 60 | (rec (cl:cdr object))))))) 61 | (rec object))) 62 | 63 | (defun appender (sourcef argument) 64 | ;; We could do some optimization here - transforming to a %LIST*, etc. 65 | `(%append ,sourcef ,@(transform-compound sourcef argument))) 66 | 67 | (defun transform-qq-argument (sourcef argument) 68 | (if (cl:atom argument) 69 | `(%quote ,sourcef ',argument) 70 | (case (cl:car argument) 71 | ((unquote) (cl:second argument)) 72 | ((unquote-splicing) (error 'unquote-splicing-at-top)) 73 | (t (appender sourcef argument))))) 74 | 75 | (defmacro quasiquote (sourcef argument) 76 | (let ((gsource (gensym "SOURCE"))) 77 | `(let ((,gsource ,sourcef)) 78 | ,(transform-qq-argument gsource argument)))) 79 | -------------------------------------------------------------------------------- /reconstruct.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | ;;; This file contains code that allows us to reconstruct a concrete 4 | ;;; syntax tree. The typical scenario is as follows: Let T be some 5 | ;;; expression concrete syntax tree, and let R be the raw version of 6 | ;;; it. Let E be a Common Lisp expression obtained by macroexpanding 7 | ;;; R. We want to construct an expression concrete syntax tree T' 8 | ;;; with E as its raw version in such a way that when E contains a 9 | ;;; subexpression S that is also in R, then we want the corresponding 10 | ;;; concrete syntax tree for S in E to be identical to the concrete 11 | ;;; syntax tree for S in T as much as possible. 12 | ;;; 13 | ;;; CST T T' 14 | ;;; │ ▲ 15 | ;;; │ raw │ reconstruct 16 | ;;; ▼ │ 17 | ;;; s-expr R ───macroexpand──▶ E 18 | ;;; │ │ 19 | ;;; │ subexpression │ subexpression 20 | ;;; ▼ ▼ 21 | ;;; s-expr S S 22 | ;;; 23 | ;;; Clearly what we want to accomplish can not always be precise. It 24 | ;;; can only be precise when S is a CONS and E contains the identical 25 | ;;; (in the sense of EQ) CONS. For atoms, we just have to guess. 26 | ;;; 27 | ;;; The technique we use works as follows: We first build an EQ hash 28 | ;;; table H1, mapping all CONS cells of R to a corresponding concrete 29 | ;;; syntax tree in T. Notice that it is possible that several 30 | ;;; concrete syntax trees of T have the identical raw version (because 31 | ;;; of the #n= and #n# reader macros). In that case we make an 32 | ;;; arbitrary choice of one such concrete syntax tree. Next, we 33 | ;;; create an EQL hash table H2, and we traverse E. For each CONS of 34 | ;;; E that has a corresponding concrete syntax tree in H1, we create 35 | ;;; the analogous correspondence in H2. After that, we again traverse 36 | ;;; R, this time looking for atoms. As long as we are outside a CONS 37 | ;;; in H2, we always replace a (or create a new) mapping when we see 38 | ;;; an atom. If we are inside a CONS in H2, we only create a mapping 39 | ;;; when one does not already exist. This way, preference is given to 40 | ;;; atoms outside of any CONS that is common between E and R, so that 41 | ;;; we get somewhat better source information for the atom in E which 42 | ;;; is not in a shared cons. 43 | ;;; Finally, we build T' recursively by traversing E, When a mapping 44 | ;;; in H2 is found, we return it. Otherwise we create a new concrete 45 | ;;; syntax tree for it. 46 | 47 | ;;; Given a CST, return a hash table mapping every CONS of the 48 | ;;; underlying raw expression to a corresponding CST. Notice that a 49 | ;;; CONS cells can be the raw version of several CSTs, so the mapping 50 | ;;; is not unique. In this case, we just pick the first corresponding 51 | ;;; CST we encounter. By doing it this way, we also avoid infinite 52 | ;;; computations when the expression contains cycles. 53 | (defun cons-table (cst &optional (cons->cst (make-hash-table :test #'eq))) 54 | (with-bounded-recursion (enqueue do-work worklist) 55 | (labels ((traverse (cst depth) 56 | (declare (type (integer 0 #.+recursion-depth-limit+) depth)) 57 | (when (consp cst) 58 | (let ((raw (raw cst))) 59 | (cond ((nth-value 1 (gethash raw cons->cst))) 60 | ((< depth +recursion-depth-limit+) 61 | (setf (gethash raw cons->cst) cst) 62 | (let ((depth+1 (1+ depth))) 63 | (traverse (first cst) depth+1) 64 | ;; If we could inquire about tail call 65 | ;; optimization, we could make this second 66 | ;; call without increasing the depth in 67 | ;; case of TCO. 68 | (traverse (rest cst) depth+1))) 69 | (t 70 | (enqueue cst))))))) 71 | (traverse cst 0) 72 | (do-work (cst) 73 | (traverse cst 0)))) 74 | cons->cst) 75 | 76 | ;;; Given an expression E and a hash table H1 mapping CONS cells to 77 | ;;; CSTs, return a new EQL hash table H2 that contains the subset of 78 | ;;; the mappings of H1 with keys in E. 79 | (defun referenced-cons-table (expression cons->cst) 80 | (let ((referenced-cons->cst (make-hash-table :test #'eql)) 81 | (seen (make-hash-table :test #'eq))) 82 | (with-bounded-recursion (enqueue do-work worklist) 83 | (labels ((traverse (expression depth) 84 | (declare (type (integer 0 #.+recursion-depth-limit+) depth)) 85 | (when (and (cl:consp expression) 86 | (not (gethash expression seen))) 87 | (setf (gethash expression seen) t) 88 | (multiple-value-bind (cst foundp) 89 | (gethash expression cons->cst) 90 | (cond ((not foundp) 91 | (let ((car (car expression)) 92 | (cdr (cdr expression))) 93 | (cond ((< depth +recursion-depth-limit+) 94 | (let ((depth+1 (1+ depth))) 95 | (traverse car depth+1) 96 | ;; If we could inquire about 97 | ;; tail call optimization, we 98 | ;; could make this second call 99 | ;; without increasing the depth 100 | ;; in case of TCO. 101 | (traverse cdr depth+1))) 102 | (t 103 | (enqueue car) 104 | (enqueue cdr))))) 105 | ;; We found EXPRESSION in CONS->CST so we 106 | ;; don't need to traverse the 107 | ;; sub-expressions of EXPRESSION since 108 | ;; we'll always use or substitute the full 109 | ;; cons when building the final CST. 110 | ((cl:null cst)) 111 | (t 112 | (setf (gethash expression referenced-cons->cst) 113 | cst))))))) 114 | (traverse expression 0) 115 | (do-work (work-item) 116 | (traverse work-item 0)))) 117 | referenced-cons->cst)) 118 | 119 | ;;; Given a CST and a table containing mappings of some of the CONSes 120 | ;;; in the CST, add the atoms of the CST as mappings to the table. 121 | ;;; Mappings are added so that, when there are two or more EQL atoms 122 | ;;; in the CST, then priority is given to one of the atoms that is 123 | ;;; defined OUTSIDE one of the CONSes already in the table. 124 | (defun add-atoms (cst table sub-expression-count) 125 | (let ((seen (make-hash-table :test #'eq :size sub-expression-count))) 126 | (with-bounded-recursion (enqueue do-work worklist) 127 | (labels ((traverse (cst inside-p depth) 128 | (declare (type (integer 0 #.+recursion-depth-limit+) depth)) 129 | (cond ((consp cst) 130 | (unless (gethash cst seen) 131 | (setf (gethash cst seen) t) 132 | (let ((first (first cst)) 133 | (rest (rest cst))) 134 | (cond ((< depth +recursion-depth-limit+) 135 | (let ((new-inside-p (or inside-p 136 | (gethash (raw cst) table))) 137 | (depth+1 (1+ depth))) 138 | (traverse first new-inside-p depth+1) 139 | (traverse rest new-inside-p depth+1))) 140 | (t 141 | (enqueue first) 142 | (enqueue rest)))))) 143 | ((atom cst) 144 | (let ((raw (raw cst))) 145 | (when (or (not inside-p) 146 | (not (nth-value 1 (gethash raw table)))) 147 | (setf (gethash raw table) cst))))))) 148 | (traverse cst nil 0) 149 | (do-work (work-item) 150 | (traverse work-item nil 0))))) 151 | table) 152 | 153 | (defmethod reconstruct ((client t) (expression t) (cst cst) 154 | &key (default-source (source cst))) 155 | (let* ((cons-table (cons-table cst)) 156 | (referenced-cons-table (referenced-cons-table expression cons-table))) 157 | (add-atoms cst referenced-cons-table (hash-table-size cons-table)) 158 | (cst-from-expression expression :source default-source 159 | :expression->cst referenced-cons-table))) 160 | 161 | (defmethod reconstruct ((client t) (expression t) (cst cl:sequence) 162 | &key default-source) 163 | (let* ((cons-table (reduce #'cons-table cst 164 | :initial-value (make-hash-table :test #'eq) 165 | :from-end t)) 166 | (referenced-cons-table (referenced-cons-table expression cons-table)) 167 | (sub-expression-count (hash-table-count cons-table))) 168 | (reduce (lambda (cst table) 169 | (add-atoms cst table sub-expression-count)) 170 | cst :initial-value referenced-cons-table :from-end t) 171 | (cst-from-expression expression :source default-source 172 | :expression->cst referenced-cons-table))) 173 | -------------------------------------------------------------------------------- /utilities.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:concrete-syntax-tree) 2 | 3 | (defconstant +recursion-depth-limit+ 1000) 4 | 5 | ;;; Evaluate BODY in a lexical environment in which 6 | ;;; * ENQUEUE-NAME is bound to a function of one argument that enqueues a 7 | ;;; work item for later processing 8 | ;;; * PROCESS-NAME is bound to a do-style iteration macro for 9 | ;;; processing queued work items with the following syntax 10 | ;;; 11 | ;;; (PROCESS-NAME (item) 12 | ;;; (do-something item)) 13 | ;;; 14 | ;;; BODY should start by attempting to perform the intended processing 15 | ;;; recursively and enqueue work items when the recursion depth 16 | ;;; reaches `+recursion-depth-limit+'. After that, BODY use 17 | ;;; PROCESS-NAME to process queued work items. This processing may add 18 | ;;; new work items if the maximum recursion depth is reached again. 19 | ;;; 20 | ;;; Thus a typical use looks like 21 | ;;; 22 | ;;; (with-bounded-recursion (enqueue do-work) 23 | ;;; (labels ((process-recursively (thing depth) 24 | ;;; (let ((sub-thing ...)) 25 | ;;; (if (< depth +recursion-depth-limit+) 26 | ;;; (process-recursively sub-thing (1+ depth)) 27 | ;;; (enqueue sub-thing))))) 28 | ;;; (process-recursively root-thing 0) 29 | ;;; (do-work (item) 30 | ;;; (process-recursively item 0)))) 31 | ;;; 32 | ;;; For typical, small inputs, the worklist will remain empty and the 33 | ;;; DO-WORK loop will exit without a single iteration. 34 | (defmacro with-bounded-recursion ((enqueue-name process-name 35 | &optional (worklist-var (gensym "WORKLIST"))) 36 | &body body) 37 | (let ((tail (gensym "TAIL"))) 38 | `(let ((,tail nil) (,worklist-var ())) 39 | (flet ((,enqueue-name (item) 40 | (let ((cell (cl:cons item nil))) 41 | (if (cl:null ,worklist-var) 42 | (setf ,worklist-var cell) 43 | (setf (cdr ,tail) cell)) 44 | (setf ,tail cell)))) 45 | (declare (dynamic-extent (function ,enqueue-name))) 46 | (macrolet ((,process-name ((item-name) &body body) 47 | `(loop until (cl:null ,',worklist-var) 48 | for ,item-name = (pop ,',worklist-var) 49 | do (progn ,@body)))) 50 | ,@body))))) 51 | -------------------------------------------------------------------------------- /version-string.sexp: -------------------------------------------------------------------------------- 1 | "0.2.0" 2 | --------------------------------------------------------------------------------