Plaster
New
List
Login
common-lisp
default
anonymous
2022.12.09 12:14:20
;;;; File "capitalized-export-test.lisp" ;;;; ;;;; Testing exporting by capitalizing symbols. (in-package :capitalized-export) (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* (make-capitalized-export-readtable))) (defclass Person () ((%name :initarg :name :accessor Name :initform nil) (%age :initarg :age :accessor Age :initform nil))) ;; CAPITALIZED-EXPORT> (do-external-symbols (s) (print s)) ;; NIL ;; CAPITALIZED-EXPORT> (load "capitalized-export-test.lisp") ;; Before: ;; ;; ((DEFCLASS |Person| NIL ;; ((%NAME :INITARG :NAME :ACCESSOR |Name| :INITFORM NIL) ;; (%AGE :INITARG :AGE :ACCESSOR |Age| :INITFORM NIL)))) ;; After: ;; ;; ((DEFCLASS PERSON NIL ;; ((%NAME :INITARG :NAME :ACCESSOR NAME :INITFORM NIL) ;; (%AGE :INITARG :AGE :ACCESSOR AGE :INITFORM NIL))) ;; (EXPORT '(AGE NAME PERSON))) ;; T ;; CAPITALIZED-EXPORT> (do-external-symbols (s) (print s)) ;; ;; PERSON ;; NAME ;; AGE ;;;; File "capitalized-export.lisp" (defpackage :capitalized-export (:use :cl)) (in-package :capitalized-export) (defun string-capitalized-p (string) ;; capitalized-ish (and (not (zerop (length string))) (some #'lower-case-p string))) (defun make-inverted-readtable () (let ((rt (copy-readtable nil))) (setf (readtable-case rt) :invert) rt)) (defun map-tree-leaves (fn tree) (labels ((walk (tr) (typecase tr (cons (cons (walk (car tr)) (walk (cdr tr)))) (atom (funcall fn tr))))) (walk tree))) (defun make-capitalized-export-readtable () (buffering-readtable:make-buffering-readtable :inner-readtable (make-inverted-readtable) :translate-all (lambda (forms) (let* ((exports ()) (collect-capitalized (lambda (object) (if (and (symbolp object) (string-capitalized-p (symbol-name object))) (progn (let ((upcased-symbol (intern (string-upcase object) *package*))) (push upcased-symbol exports) upcased-symbol)) object))) (translated-forms (append (map-tree-leaves collect-capitalized forms) `((export ',exports))))) (format t "Before:~%") (with-standard-io-syntax (let ((*print-pretty* t) (*package* (find-package :capitalized-export))) (print forms))) (terpri) (format t "After:~%") (with-standard-io-syntax (let ((*print-pretty* t) (*package* (find-package :capitalized-export))) (print translated-forms))) translated-forms))))
Raw
Annotate
Repaste
Edit