/[advanced-readtable]/src.lisp
ViewVC logotype

Diff of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 12 by rklochkov, Mon Dec 31 13:39:29 2012 UTC revision 14 by rklochkov, Fri Jan 25 14:09:35 2013 UTC
# Line 10  Line 10 
10  ;;;;                                    package::symbol1 and package::symbol2  ;;;;                                    package::symbol1 and package::symbol2
11    
12  (defvar *per-package-finders* (make-hash-table :test 'eq)  (defvar *per-package-finders* (make-hash-table :test 'eq)
13    "Hash package -> list of handlers. Each handler is a cons (key . function)")    "Hash package -> list of handlers. Each handler is a cons (key . function)
14    function = (lambda (name package) ...) -> package")
15    
16  (defvar *package-finders* nil  (defvar *package-finders* nil
17    "List of handlers. Each handler is a cons (key . function)    "List of handlers. Each handler is a cons (key . function)
18  function = (lambda (name package) ...) -> package")  function = (lambda (name package) ...) -> package")
19    
20    (defvar *global-nicknames* nil
21      "Placeholder for global nicknames, when not null, it is an alias hash")
22    
23  ;;;  ;;;
24  ;;; Prepare readtables  ;;; Prepare readtables
25  ;;;  ;;;
26    
 (defvar *advanced-readtable* (copy-readtable nil))  
27  (defvar *colon-readtable* (copy-readtable nil)  (defvar *colon-readtable* (copy-readtable nil)
28    "Support readtable with colon as whitespace")    "Support readtable with colon as whitespace")
29    (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
30    
31  ;;;  ;;;
32  ;;; Readtable handlers  ;;; Readtable handlers
33  ;;;  ;;;
34    
35  (defpackage #:advanced-readtable.junk)  (|CL|:defpackage #:advanced-readtable.junk)
36    
37  (defun try-funcall (handlers-list name package)  (defun try-funcall (handlers-list name package)
38    (declare (type list handlers-list)    (declare (type list handlers-list)
# Line 42  function = (lambda (name package) ...) - Line 47  function = (lambda (name package) ...) -
47  1. By full name with CL:FIND-PACKAGE.  1. By full name with CL:FIND-PACKAGE.
48  2. By per-package handlers. Here we wil try local-nicknames and so on.  2. By per-package handlers. Here we wil try local-nicknames and so on.
49  3. By global handlers. Here we may use, for example, hierarchical packages."  3. By global handlers. Here we may use, for example, hierarchical packages."
50    (declare (type (or null package) current-package))    (declare (type package current-package))
51    (if (typep name 'package) name    (if (typep name 'package) name
52        (let ((sname (string name)))        (let ((sname (string name)))
53          (or          (or
54           (cl:find-package name)           (cl:find-package name)
55           (when current-package           (try-funcall (package-finders current-package)
56             (try-funcall (package-finders current-package)                        sname current-package)
                         sname current-package))  
57           (try-funcall *package-finders* sname current-package)))))           (try-funcall *package-finders* sname current-package)))))
58    
59  (defvar *package-symbol-finders* (make-hash-table :test 'eq)  (defvar *package-symbol-finders* (make-hash-table :test 'eq)
60    "Hash package -> list of handlers. Each handler is a cons (key . function)")    "Hash package -> list of handlers. Each handler is a cons (key . function)
61    function =  (lambda (name package) ...) -> symbol")
62    
63  (defvar *symbol-finders* nil  (defvar *symbol-finders* nil
64    "List of handlers. Each handler is a cons (key . function)    "List of handlers. Each handler is a cons (key . function)
65  function =  (lambda (name package) ...) -> symbol")  function =  (lambda (name package) ...) -> symbol")
66    
67  (defvar *extra-finders* (make-hash-table :test 'eq)  (defvar *extra-finders* (make-hash-table :test 'eq)
68    "Hash symbol -> list of handlers. Each handler is a cons (key . function)    "Hash symbol -> list of handlers. Each handler is a cons (key . function)
69  function = (lambda (name package) ...) -> symbol  function = (lambda (name package) ...) -> symbol
70  These will be used before CL:FIND-SYMBOL")  These will be used before CL:FIND-SYMBOL")
71    
72  (defvar *symbol-readmacros* (make-hash-table :test 'eq))  (defvar *symbol-readmacros* (make-hash-table :test 'eq))
73    
74  (defvar *disable-symbol-readmacro* nil  (defvar *disable-symbol-readmacro* nil
75    "Disables processing of symbol-readmacro.")    "Disables processing of symbol-readmacro.")
76    
# Line 109  Returns function, assigned by set-macro- Line 117  Returns function, assigned by set-macro-
117            (values symbol status)            (values symbol status)
118            (try-funcall (cdr handlers-list) name package)))))            (try-funcall (cdr handlers-list) name package)))))
119    
   
120  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
121    "We try to find symbol    "We try to find symbol
122  1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE  1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
# Line 119  Returns function, assigned by set-macro- Line 126  Returns function, assigned by set-macro-
126  5. By global finders  5. By global finders
127  6. By CL-FIND-SYMBOL"  6. By CL-FIND-SYMBOL"
128    (declare (type string name))    (declare (type string name))
129    ;  (when (string= name "NIL")
130    ;    (return-from find-symbol (cl:find-symbol name (or dpackage *package*))))
131    (let ((package (if dpackage (find-package dpackage) *package*)))    (let ((package (if dpackage (find-package dpackage) *package*)))
132      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
133                   (if clauses                   (if clauses
134                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
135                          (if symbol (values symbol status)                          (if status (values symbol status)
136                              (mv-or . ,(cdr clauses))))                              (mv-or . ,(cdr clauses))))
137                       `(values nil nil))))                       `(values nil nil))))
   
138        (mv-or        (mv-or
139         (try-mv-funcall *extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
140         (when dpackage (cl:find-symbol name package))         (when dpackage (cl:find-symbol name package))
# Line 135  Returns function, assigned by set-macro- Line 143  Returns function, assigned by set-macro-
143         (try-mv-funcall *symbol-finders* name package)         (try-mv-funcall *symbol-finders* name package)
144         (unless dpackage (cl:find-symbol name package))))))         (unless dpackage (cl:find-symbol name package))))))
145    
146    (defun collect-dots (stream)
147      (do ((n 0 (1+ n))
148           (c (read-char stream nil) (read-char stream nil)))
149          ((or (null c) (char/= c #\.))
150           (when c
151             (unread-char c stream))
152           (if (and (plusp n) (member c '(nil #\Space #\) #\( #\Tab #\Newline #\:)))
153             (intern (make-string n :initial-element #\.))
154             (dotimes (foo n) (unread-char #\. stream))))))
155    
156  (defun read-token (stream)  (defun read-token (stream)
157    "    "
158  DO: Reads from STREAM a symbol or number up to whitespace or colon  DO: Reads from STREAM a symbol or number up to whitespace or colon
159  RETURN: symbols name or numbers value"  RETURN: symbols name or numbers value"
160    (let ((*readtable* *colon-readtable*)    (let ((*readtable* *colon-readtable*)
161          (*package* (cl:find-package '#:advanced-readtable.junk)))          (*package* (cl:find-package '#:advanced-readtable.junk)))
162      (read-preserving-whitespace stream nil)))      (or (collect-dots stream)
163            (read-preserving-whitespace stream nil))))
164    
165  (defun count-colons (stream)  (defun count-colons (stream)
166    "    "
167  DO: Reads colons from STREAM  DO: Reads colons from STREAM
168  RETURN: number of the colons"  RETURN: number of the colons"
169    (let ((c (read-char stream nil)))    (do ((n 0 (1+ n))
170      (if (eql c #\:)         (c (read-char stream nil) (read-char stream nil)))
171          (+ 1 (count-colons stream))        ((or (null c) (char/= c #\:))
172          (progn (unread-char c stream) 0))))         (when c (unread-char c stream)) n)))
173    
174  (defun read-after-colon (stream maybe-package colons)  (defun read-after-colon (stream maybe-package colons)
175    "Read symbol package:sym or list package:(...)"    "Read symbol package:sym or list package:(...)"
176    (declare (type stream stream)    (declare (type stream stream)
177             (type (integer 0 2) colons))             (type integer colons))
178    (check-type colons (integer 0 2))    (check-type colons (integer 0 2))
179    (when (= colons 0) ; no colon: this is a symbol or an atom    (when (= colons 0) ; no colon: this is a symbol or an atom
180      (return-from read-after-colon      (return-from read-after-colon
# Line 186  RETURN: number of the colons" Line 205  RETURN: number of the colons"
205          (unless status          (unless status
206            (if (= colons 1) (error "No external symbol ~S in ~S"            (if (= colons 1) (error "No external symbol ~S in ~S"
207                                    (symbol-name token) package)                                    (symbol-name token) package)
208                (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"                (progn
209                        (symbol-name token) package)))                  (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
210                            (symbol-name token) package)
211                    (setf symbol (intern (symbol-name token) package)))))
212          (unintern token)          (unintern token)
213          (when (and (= colons 1) (not (eq status :external)))          (when (and (= colons 1) (not (eq status :external)))
214            (cerror "Use anyway"            (cerror "Use anyway"
215                    "Symbol ~A not external" symbol))                    "Symbol ~A not external" symbol))
216          symbol))))          symbol))))
217    
   
   
218  (defun read-token-with-colons (stream char)  (defun read-token-with-colons (stream char)
219    "Reads token, then analize package part if needed"    "Reads token, then analize package part if needed"
220    (unread-char char stream)    (unread-char char stream)
# Line 227  RETURN: number of the colons" Line 246  RETURN: number of the colons"
246    (defun open-paren-reader (stream char)    (defun open-paren-reader (stream char)
247      (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))      (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
248        (funcall default-open-paren-reader stream char))))        (funcall default-open-paren-reader stream char))))
   
   
249    
250  (defun (setf package-finders) (value &optional (package *package*))  (defun (setf package-finders) (value &optional (package *package*))
251    (setf (gethash (find-package package) *per-package-finders*) value))    (setf (gethash (find-package package) *per-package-finders*) value))
# Line 310  LIB version 2, one can simply rename LIB Line 327  LIB version 2, one can simply rename LIB
327  version 2 to LIB2 and make  version 2 to LIB2 and make
328   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
329   (push-local-nickname :lib2 :lib :b)   (push-local-nickname :lib2 :lib :b)
330    
331    If enabled global-nicknames via enable-global-nicknames,
332    then also created alias in current package.
333    
334    For example,
335     (push-local-nickname :lib1 :lib :a), states, that package A.LIB is eq to LIB1.
336  "  "
337    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package))
338      (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name          (s-nick (string nick)))
339        (when (string= name (string nick)) dpackage))))      (%set-handler (package-finders current-package)
340                      `(:nick ,(string long-package) ,s-nick) name
341          (when (string= name s-nick) dpackage))
342        (when *global-nicknames*
343          (setf (gethash (concatenate 'string
344                                      (package-name current-package)
345                                      "." s-nick) *global-nicknames*)
346                dpackage))))
347    
348  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
349    "Sets local-package for a symbol. Many macroses use there own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
# Line 333  For example, this will be error: Line 363  For example, this will be error:
363        (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)        (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
364          (when (eq status :external) symbol)))))          (when (eq status :external) symbol)))))
365    
366    ;;; TODO: process nicknames in hierarchy
367    ;;; ex: cl-user.test == common-lisp-user.test
368    ;;; cl-user.test.a == common-lisp-user.test.a
369    
370    (defun normalize-package (name)
371      "Returns nil if already normalized.
372    Replace first section of hierarchy with proper name"
373      (let ((pos (position #\. name)))
374        (when pos
375          (if (= pos 0)  ; .subpackage
376              (concatenate 'string (package-name *package*) name)
377              (let* ((base (subseq name 0 pos))
378                     (p (find-package base)))
379                (when (and p (string/= (package-name p) base))
380                  (concatenate 'string (package-name p) "."
381                               (subseq name (1+ pos)))))))))
382    
383    (flet ((parent (name)
384             (let ((pos (position #\. name :from-end t)))
385               (if pos (subseq name 0 pos) "")))
386           (relative-to (parent name)
387             (cond
388               ((string= parent "") name)
389               ((string= name "") parent)
390               (t (concatenate 'string parent "." name)))))
391      (defun hierarchy-find-package (name package)
392        (if (char= (char name 0) #\.)
393          (do ((i 1 (1+ i))
394               (p (package-name package) (parent p)))
395              ((or (= i (length name)) (char/= (char name i) #\.))
396               (find-package (relative-to p (subseq name i)))))
397          (let ((normalized (normalize-package name)))
398            (when normalized
399              (find-package normalized package))))))
400    
401    (defun correct-package (designator)
402      (let ((p (find-package designator)))
403        (if p (package-name p) designator)))
404    
405    (defmacro in-package (designator)
406      `(|CL|:in-package ,(correct-package (string designator))))
407    
408    (defmacro defpackage (package &rest options)
409      (let ((normalized (normalize-package (string package)))
410            (options
411             (mapcar (lambda (option)
412                       (cons (car option)
413                             (case (car option)
414                               (:use (mapcar #'correct-package (cdr option)))
415                               ((:import-from :shadowing-import-from)
416                                (cons (correct-package (second option))
417                                      (cddr option)))
418                               (t (cdr option)))))
419                     options)))
420        `(|CL|:defpackage ,(or normalized package) . ,options)))
421    
422    (defun substitute-symbol (stream symbol)
423      (declare (ignore stream))
424      (find-symbol (symbol-name symbol) #.*package*))
425    
426    (defun enable-hierarchy-packages ()
427      (set-handler *package-finders* :hierarchy #'hierarchy-find-package)
428      (set-macro-symbol '|CL|:in-package #'substitute-symbol)
429      (set-macro-symbol '|CL|:defpackage #'substitute-symbol))
430    
431    (defun enable-global-nicknames ()
432      (setf *global-nicknames* (make-hash-table :test 'equal))
433      (%set-handler *package-finders* :global-nicknames name
434        (gethash name *global-nicknames*)))
435    
436    (enable-hierarchy-packages)
437    (enable-global-nicknames)
438    
439  ;;;  ;;;
440  ;;; Readtable analysis and change  ;;; Readtable analysis and change
441  ;;;  ;;;
442    (eval-when (:compile-toplevel :load-toplevel :execute)
443  (defmacro with-case (case &body body)    (defmacro with-case (case &body body)
444    (let ((save (gensym)))      (let ((save (gensym)))
445      `(let ((,save (readtable-case *readtable*)))        `(let ((,save (readtable-case *readtable*)))
446         (setf (readtable-case *readtable*) ,case)           (setf (readtable-case *readtable*) ,case)
447         (unwind-protect           (unwind-protect
448              (progn ,@body)                (progn ,@body)
449           (setf (readtable-case *readtable*) ,save)))))             (setf (readtable-case *readtable*) ,save)))))
450    
451  (defun does-not-terminate-token-p (c)    (defun does-not-terminate-token-p (c)
452    (ignore-errors      (ignore-errors
453      (let ((str (format nil "a~Ab" c)))        (let ((str (format nil "a~Ab" c)))
454        (string= str (symbol-name          (string= str (symbol-name
455                      (with-case :preserve                        (with-case :preserve
456                        (read-from-string (format nil "#:~A" str))))))))                          (read-from-string (format nil "#:~A" str))))))))
457    
458      (defun whitespace-p (c)
459  (defun whitespace-p (c)      (ignore-errors
460    (ignore-errors        (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
461      (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))  
462      (defun multiple-escape-p (c)
463  (defun multiple-escape-p (c)      (ignore-errors
464    (ignore-errors        (string= "qQ" (symbol-name
465      (string= "qQ" (symbol-name                       (with-case :upcase
466                     (with-case :upcase                         (read-from-string (format nil "#:~AqQ~A" c c)))))))
467                       (read-from-string (format nil "#:~AqQ~A" c c)))))))  
468      (defun single-escape-p (c)
469  (defun single-escape-p (c)      (ignore-errors
470    (ignore-errors        (string= (symbol-name '#:\ ) (symbol-name
471      (string= (symbol-name '#:\ ) (symbol-name                                      (read-from-string
472                                    (read-from-string (format nil "#:~A'" c))))))                                       (format nil "#:~A'" c))))))
473    
474      (defun macro-char-p (c)
475        "If C is macro-char, return GET-MACRO-CHARACTER"
476  (defun macro-char-p (c)      #+allegro (unless
477    "If C is macro-char, return GET-MACRO-CHARACTER"                    (eql (get-macro-character c) #'excl::read-token)
478    #+allegro (unless                  (get-macro-character c))
479                  (eql (get-macro-character c) #'excl::read-token)      #-allegro (get-macro-character c))
480                (get-macro-character c))  
481    #-allegro (get-macro-character c))    (defun to-process (c)
482        (cond
483  (defun fill-char-table ()        ((eql c #\:) nil)
484    "Returns simple-vector with character syntax classes"        ((macro-char-p c) nil)
485    (let ((*readtable* (copy-readtable nil))        ((does-not-terminate-token-p c) t)
486          (char-table (make-array 127)))        ((whitespace-p c) nil)
487      (dotimes (i (length char-table))        ((multiple-escape-p c) t)
488        (let ((c (code-char i)))        ((single-escape-p c) t)
489          (setf        (t nil)))
          (svref char-table i)  
          (cond  
            ((eql c #\:) :colon)  
            ((macro-char-p c) :macro)  
            ((does-not-terminate-token-p c) :does-not-terminate-token)  
            ((whitespace-p c) :whitespace)  
            ((multiple-escape-p c) :multiple-escape)  
            ((single-escape-p c) :single-escape)))))  
     char-table))  
   
 (let (initialized)  
   (defun activate (&optional force)  
     "Inits *advanced-readtable* and *colon-readtable*."  
     (when (or force (not initialized))  
       (setq initialized t)  
       (let ((char-table (fill-char-table)))  
         (dotimes (i (length char-table))  
           (let ((b (svref char-table i))  
                 (c (code-char i)))  
             (unless (char= #\# c)  
               (when (member b '(:does-not-terminate-token  
                                 :multiple-escape :single-escape))  
                 ;; will make it non-terminating macro character  
                 ;;    = potentially beginning of the package-name  
                 (set-macro-character c #'read-token-with-colons  
                                      t *advanced-readtable*))))))  
490    
491        (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)    (defparameter +additional-chars+ ""
492        (set-macro-character #\( #'open-paren-reader nil *advanced-readtable*))      "Fill this, if you need extra characters for packages to begin with")
493      (setf *readtable* *advanced-readtable*)))  
494      (defun chars-to-process ()
495        (let ((*readtable* (copy-readtable nil)))
496          (nconc
497           (loop :for i :from 1 :to 127
498              :for c = (code-char i)
499              :when (to-process c) :collect c)
500           (loop :for c :across +additional-chars+
501              :when (to-process c) :collect c))))
502    
503      (defun make-named-rt ()
504        `(,(cl:find-symbol "DEFREADTABLE" "NAMED-READTABLES") :advanced
505           (:merge :standard)
506           ,@(loop :for c :in (chars-to-process)
507                :collect `(:macro-char ,c #'read-token-with-colons t))
508           (:macro-char #\( #'open-paren-reader nil))))
509    
510    (macrolet ((def-advanced-readtable ()
511                 (make-named-rt)))
512      (when (cl:find-package "NAMED-READTABLES")
513        (def-advanced-readtable)))
514    
515    (defun activate ()
516      (dolist (c (chars-to-process))
517        (set-macro-character c #'read-token-with-colons t))
518      (set-macro-character #\( #'open-paren-reader t))
519    
520  (defun ! () (activate))  (defun ! () (activate))

Legend:
Removed from v.12  
changed lines
  Added in v.14

  ViewVC Help
Powered by ViewVC 1.1.5