git.fiddlerwoaroof.com
eclector-test.lisp
d5124d99
 (defpackage :fwoar.lisp-sandbox.eclector-test
   (:use :cl )
   (:export ))
 (in-package :fwoar.lisp-sandbox.eclector-test)
 
 (defvar *verbose* nil)
 
 (defclass my-reader ()
   ())
 (defvar *eclector-client*
   (make-instance 'my-reader))
 
 (fw.lu:defclass+ fw-package ()
   ((%name :initarg :name :reader fw-name)
    (%symbols :reader fw-symbols :initform (make-hash-table :test 'equal))))
 
 
 (defvar *fw-packages*
   (alexandria:alist-hash-table (list (cons "KEYWORD" (fw-package "KEYWORD")))
                                :test 'equal))
 
 (defmethod print-object ((o fw-package) s)
   (print-unreadable-object (o s :type t :identity t)
     (format s "~s with ~d symbols"
             (fw-name o)
             (hash-table-count (fw-symbols o)))))
 
 (defgeneric my-intern (symbol package)
   (:method ((symbol string) (package package))
     (intern symbol package))
   (:method ((symbol string) (package fw-package))
     (when *verbose*
       (:printv symbol package))
     (if (eql package (ensure-package "KEYWORD"))
         (intern symbol (find-package "KEYWORD"))
         (fw.lu:if-let* ((s-p (find-package (fw-name package)))
                         (s-s (and s-p (find-symbol symbol s-p)))
                         (_ (not (eql s-p (symbol-package s-s)))))
           (my-intern symbol
                      (ensure-package
                       (package-name
                        (symbol-package s-s))))
           (alexandria:ensure-gethash symbol
                                      (fw-symbols package)
                                      (make-symbol symbol))))))
 
 (defgeneric my-find-symbol (symbol package)
   (:method ((symbol string) (package package))
     (find-symbol symbol package))
   (:method ((symbol string) (package fw-package))
     (gethash symbol (fw-symbols package))))
 
 (defun my-find-package (package)
   (gethash package *fw-packages*))
 
 (defun ensure-package (package)
   (etypecase package
     (fw-package package)
     (package (ensure-package (package-name package)))
     (symbol (ensure-package (symbol-name package)))
     (string (alexandria:ensure-gethash package *fw-packages*
                                        (fw-package package)))))
 
 (defmethod eclector.reader:interpret-symbol
     ((client my-reader) input-stream package-indicator symbol-name internp)
   (let ((package (case package-indicator
                    (:current (ensure-package *package*))
                    (:keyword (ensure-package "KEYWORD"))
                    (t        (or (ensure-package package-indicator))))))
     (if *verbose*
         (:printv package-indicator package symbol-name (my-intern symbol-name package))
         (my-intern symbol-name package))))
 
 (defparameter *my-readtable*
   (let ((readtable (eclector.readtable:copy-readtable eclector.reader:*readtable*)))
     (eclector.readtable:set-dispatch-macro-character
      readtable #\# #\+
      (lambda (stream char parameter)
        parameter
        char
        (:printv
         eclector.reader:*client*
         (let ((*verbose* t))
           (cons 'when-feature
                 (eclector.reader:read stream t
                                       nil t))))))
     (eclector.readtable:set-dispatch-macro-character
      readtable #\# #\-
      (lambda (stream char parameter)
        parameter
        char
        (:printv
         eclector.reader:*client*
         (let ((*verbose* t))
           (cons 'unless-feature
                 (eclector.reader:read stream t
                                       nil t))))))
     readtable))
 
 (defun my-read-from-string (string)
   (let ((eclector.reader:*client* *eclector-client*)
         (eclector.reader:*readtable* *my-readtable*))
     (eclector.reader:read-from-string string)))