Plaster
New
List
Login
text
apl
aspx
asterisk
brainfuck
c
c++hdr
c++src
cassandra
ceylon
clojure
clojurescript
cmake
cobol
coffeescript
common-lisp
crystal
csharp
css
cypher-query
cython
d
dart
diff
django
dockerfile
dylan
ebnf
ecl
ecmascript
edn
eiffel
ejs
elm
erb
erlang
ez80
factor
fcl
feature
forth
fortran
fragment
gfm
go
gql
groovy
gss
haml
handlebars-template
haskell
haxe
hive
html
http
httpd-php
httpd-php-open
hxml
ini
java
javascript
json
jsp
jsx
julia
kotlin
latex
less
literate-haskell
lua
mariadb
markdown
mbox
mirc
mscgen
msgenny
mssql
mumps
mysql
n-triples
nesc
nginx-conf
nsis
objectivec
octave
oz
pascal
perl
pgp
pgp-keys
pgp-signature
pgsql
php
pig
plsql
properties
protobuf
puppet
python
q
rpm-changes
rpm-spec
rsrc
ruby
rustsrc
sas
sass
scala
scheme
scss
sieve
slim
smarty
solr
soy
sparql-query
spreadsheet
sql
squirrel
stex
styl
swift
systemverilog
tcl
textile
tiddlywiki
tiki
tlv
tornado
ttcn-asn
ttcn-cfg
turtle
twig
typescript
typescript-jsx
vb
vbscript
velocity
verilog
vertex
vhdl
vue
webidl
xml
xml-dtd
xquery
xu
yaml
z80
default
Visibility:
public
unlisted
private
(defclass no-macro-expansion-walker-metaenv (agnostic-lizard:walker-metaenv) () (:documentation "A walker that performs no macro expansions. :ON-MACROEXPANDED-FORM is never called. For macro operators, only :ON-EVERY-FORM-PRE is called.")) (defmethod initialize-instance :after ((env no-macro-expansion-walker-metaenv) &key on-macroexpanded-form &allow-other-keys) (declare (ignore on-macroexpanded-form)) ;; TODO: We can't really signal a warning or an error when ;; ON-MACROEXPANDED-FORM is provided as it's regularly passed during cloning. ;; I guess this is just part of the interface of WALKER-METAENV and its ;; subclasses? ;; ;; (when on-macroexpanded-form ;; (warn "~s was specified but ~s doesn't perform any macro expansions" ;; 'on-macroexpanded-form 'no-macro-expansion-walker-metaenv)) ;; ;; Because we had to duplicate METAENV-MACROEXPAND-ALL's logic in order to ;; implement macro expansion inhibition, we don't need these wrapping handlers ;; below. :ON-MACROEXPANDED-FORM is simply never called. ;; (let ((last-form nil) ;; (old-on-every-form-pre ;; (agnostic-lizard::metaenv-on-every-form-pre env)) ;; (old-on-macroexpanded-form ;; (agnostic-lizard::metaenv-on-macroexpanded-form env))) ;; (setf (agnostic-lizard::metaenv-on-every-form-pre env) ;; (lambda (f e) ;; (setf last-form f) ;; (funcall old-on-every-form-pre f e)) ;; (agnostic-lizard::metaenv-on-macroexpanded-form env) ;; (lambda (f e) ;; (funcall old-on-macroexpanded-form f e) ;; last-form))) env) (defmethod print-object ((env no-macro-expansion-walker-metaenv) stream) (print-unreadable-object (env stream :type t :identity t))) (defmethod agnostic-lizard::metaenv-clone ((env no-macro-expansion-walker-metaenv) &optional overrides) (apply #'make-instance 'no-macro-expansion-walker-metaenv (append overrides (agnostic-lizard::metaenv-clone-args env)))) (defmethod agnostic-lizard:metaenv-macroexpand-all (form (env no-macro-expansion-walker-metaenv)) (let* ((replacement (funcall (agnostic-lizard::metaenv-on-every-form-pre env) form env)) (hardwiring-needed-p (and (consp replacement) (find (first replacement) agnostic-lizard::*hardwired-operators*))) (expanded-raw (if hardwiring-needed-p replacement (agnostic-lizard::metaenv-macroexpand replacement env))) (macrop (not (eq replacement expanded-raw)))) (if macrop replacement (let* ((function-like-p (and replacement (consp replacement))) (operator (and function-like-p (first replacement))) (specialp (and (symbolp operator) (special-operator-p operator))) (function-replacement (if (or specialp hardwiring-needed-p) (funcall (agnostic-lizard::metaenv-on-special-form-pre env) replacement env) (funcall (agnostic-lizard::metaenv-on-function-form-pre env) replacement env))) (full-expansion (cond ((not (eq function-replacement replacement)) (agnostic-lizard:metaenv-macroexpand-all function-replacement env)) ((not function-like-p) replacement) (specialp (agnostic-lizard::metaenv-macroexpand-all-special-form operator function-replacement env)) (t (agnostic-lizard::metaenv-macroexpand-all-special-form operator function-replacement env)))) (full-expansion-replacement (cond ((and function-like-p (not specialp) (not hardwiring-needed-p)) (funcall (agnostic-lizard::metaenv-on-function-form env) full-expansion env)) (function-like-p (funcall (agnostic-lizard::metaenv-on-special-form env) full-expansion env)) (t (funcall (agnostic-lizard::metaenv-on-every-atom env) full-expansion env)))) (result (funcall (agnostic-lizard::metaenv-on-every-form env) full-expansion-replacement env))) result)))) (defun walk-form-2 (form env &rest handler-definitions) (agnostic-lizard:metaenv-macroexpand-all form (apply #'make-instance (if env (class-of env) 'agnostic-lizard:walker-metaenv) (append handler-definitions (and env (agnostic-lizard::metaenv-clone-args env)))))) (defun test-walk-form-2 (form &optional env) (let ((count 0)) (macrolet ((p (msg) (let ((g!f (gensym (string 'f))) (g!env (gensym (string 'env)))) `(lambda (,g!f ,g!env) (declare (ignore ,g!env)) (incf count) (format t "~2,,,'0@s: ~s: ~s~%" count ,msg ,g!f) ,g!f)))) (my-walk-form form env :on-every-form-pre (p "on-every-form-pre") :on-every-form (p "on-every-form") :on-special-form-pre (p "on-special-form-pre") :on-special-form (p "on-special-form") :on-function-form-pre (p "on-function-form-pre") :on-function-form (p "on-function-form") :on-macroexpanded-form (p "on-macroexpanded-form") :on-every-atom (p "on-every-atom"))))) (defmacro with-overload-2 (specs &body body) (walk-form-2 `(progn ,@body) (make-instance 'no-macro-expansion-walker-metaenv) :on-function-form (lambda (f env) (declare (ignore env)) (if (consp f) (let ((rep (find (car f) specs :key #'first :test #'string-equal))) (if rep (cons (second rep) (cdr f)) f)) f))))