  -*- Mode : lisp ; Syntax : ansi - common - lisp ; Base : 10 ; Package : de.setf.resource.implementation ; -*-


(in-package :de.setf.resource.implementation)

(:documentation
  "This file defines a package-based uri-encoded-symbol reader for the `de.setf.resource` CLOS linked data library."
 
 (copyright
  "Copyright 2010 [james anderson](mailto:)  All Rights Reserved"
  "'de.setf.resource' is free software: you can redistribute it and/or modify it under the terms of version 3
  of the GNU Affero General Public License as published by the Free Software Foundation.

  'de.setf.resource' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  See the Affero General Public License for more details.

  A copy of the GNU Affero General Public License should be included with 'de.setf.resource' as `agpl.txt`.
  If not, see the GNU [site](/)."))

(defvar *lock-vocabulary-packages* t)


(defun |{-reader|
       (stream char
               &aux
               (namespace (make-array 32 :adjustable t :fill-pointer 0 :element-type 'character))
               (local-part (make-array 32 :adjustable t :fill-pointer 0 :element-type 'character)))
  "RDF-directed symbol reader"

  ;; read and intern a qname value
  (setf (fill-pointer namespace) 0
        (fill-pointer local-part) 0)
  (loop (setf char (read-char stream))
        (when (char= char #\})
          (setf namespace (or (find-symbol namespace :keyword)
                              (intern (subseq namespace 0) :keyword)))
          (return))
        (vector-push-extend char namespace))
  (cond ((eql #\| (peek-char t stream))
         ;; where explicitly escaped allow non-name characters
         (read-char stream)
         (loop (setf char (read-char stream nil nil))
               (unless char (return))
               (when (eql #\| char)
                 (return))
               (vector-push-extend char local-part)))
        (t
         (loop (setf char (read-char stream nil nil))
               (unless char (return))
               (when (or (member char '(#\space #\tab #\return #\linefeed))
                         (multiple-value-bind (function non-breaking-p)
                                              (get-macro-character char)
                           (and function (not non-breaking-p))))
                 (unread-char char stream)
                 (return))
               (vector-push-extend char local-part))))

  ;; search for the namespace in both the dynamic stack and the static definitions. the former by prefix,
  the latter by full name ; then first look for an existing name and if not found cons a new local part and
  ;; intern a new name.
  ;; if in a #- mode, return at least NIL, in order that the likely '{xx}yyy complete the '-readers'
  ;; constraints
  (if *read-suppress*
    nil
    (let* ((namespace (or (find-package namespace)
                          (error "Package not found: ~s." namespace)))
           (uname (cond ((find-symbol local-part namespace))
                        (*lock-vocabulary-packages*
                         (cerror "Create a new symbol."
                                 "The symbol is not present in the vocabulary: ~s: ~s."
                                 local-part namespace)
                         (intern (subseq local-part 0) namespace))
                        (t
                         (intern (subseq local-part 0) namespace)))))
      uname)))

(labels ((call-packaged-macro-character (stream char function-name original-readtable)
           (let ((actual-reader (find-symbol (symbol-name function-name) *package*)))
             (cond (actual-reader
                    (funcall actual-reader stream char))
                   (t
                    (unread-char char stream)
                    (let ((*readtable* original-readtable))
                      (read stream))))))
         (set-packaged-macro-character (character function-name &optional (readtable *readtable*))
           (let ((original-reader (get-macro-character character (copy-readtable nil)))
                 (original-readtable (copy-readtable readtable)))
             (flet ((maybe-reader (stream char)
                      (call-packaged-macro-character stream char function-name original-readtable)))
               (when original-reader
                 (set-macro-character character original-reader original-readtable))
               (set-macro-character character #'maybe-reader *readtable*)))))
  
  (defun install-|{-reader| ()
    #-clisp
    (set-packaged-macro-character #\{ '|{-reader|)
    
  #+clisp
  (progn
    (defun single-value-|{-reader| (stream char &aux result)
      (setf result (|{-reader| stream char))
      result)
    (set-packaged-macro-character #\{ 'single-value-|{-reader|))))

(install-|{-reader|)



 Syntax : ansi - common - lisp ; Base : 10 ; Package : de.setf.resource.implementation ; -*-
 without even the
 read and intern a qname value
 where explicitly escaped allow non-name characters
 search for the namespace in both the dynamic stack and the static definitions. the former by prefix,
 then first look for an existing name and if not found cons a new local part and
 intern a new name.
 if in a #- mode, return at least NIL, in order that the likely '{xx}yyy complete the '-readers'
 constraints


(in-package :de.setf.resource.implementation)

(:documentation
  "This file defines a package-based uri-encoded-symbol reader for the `de.setf.resource` CLOS linked data library."
 
 (copyright
  "Copyright 2010 [james anderson](mailto:)  All Rights Reserved"
  "'de.setf.resource' is free software: you can redistribute it and/or modify it under the terms of version 3
  of the GNU Affero General Public License as published by the Free Software Foundation.

  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  See the Affero General Public License for more details.

  A copy of the GNU Affero General Public License should be included with 'de.setf.resource' as `agpl.txt`.
  If not, see the GNU [site](/)."))

(defvar *lock-vocabulary-packages* t)


(defun |{-reader|
       (stream char
               &aux
               (namespace (make-array 32 :adjustable t :fill-pointer 0 :element-type 'character))
               (local-part (make-array 32 :adjustable t :fill-pointer 0 :element-type 'character)))
  "RDF-directed symbol reader"

  (setf (fill-pointer namespace) 0
        (fill-pointer local-part) 0)
  (loop (setf char (read-char stream))
        (when (char= char #\})
          (setf namespace (or (find-symbol namespace :keyword)
                              (intern (subseq namespace 0) :keyword)))
          (return))
        (vector-push-extend char namespace))
  (cond ((eql #\| (peek-char t stream))
         (read-char stream)
         (loop (setf char (read-char stream nil nil))
               (unless char (return))
               (when (eql #\| char)
                 (return))
               (vector-push-extend char local-part)))
        (t
         (loop (setf char (read-char stream nil nil))
               (unless char (return))
               (when (or (member char '(#\space #\tab #\return #\linefeed))
                         (multiple-value-bind (function non-breaking-p)
                                              (get-macro-character char)
                           (and function (not non-breaking-p))))
                 (unread-char char stream)
                 (return))
               (vector-push-extend char local-part))))

  (if *read-suppress*
    nil
    (let* ((namespace (or (find-package namespace)
                          (error "Package not found: ~s." namespace)))
           (uname (cond ((find-symbol local-part namespace))
                        (*lock-vocabulary-packages*
                         (cerror "Create a new symbol."
                                 "The symbol is not present in the vocabulary: ~s: ~s."
                                 local-part namespace)
                         (intern (subseq local-part 0) namespace))
                        (t
                         (intern (subseq local-part 0) namespace)))))
      uname)))

(labels ((call-packaged-macro-character (stream char function-name original-readtable)
           (let ((actual-reader (find-symbol (symbol-name function-name) *package*)))
             (cond (actual-reader
                    (funcall actual-reader stream char))
                   (t
                    (unread-char char stream)
                    (let ((*readtable* original-readtable))
                      (read stream))))))
         (set-packaged-macro-character (character function-name &optional (readtable *readtable*))
           (let ((original-reader (get-macro-character character (copy-readtable nil)))
                 (original-readtable (copy-readtable readtable)))
             (flet ((maybe-reader (stream char)
                      (call-packaged-macro-character stream char function-name original-readtable)))
               (when original-reader
                 (set-macro-character character original-reader original-readtable))
               (set-macro-character character #'maybe-reader *readtable*)))))
  
  (defun install-|{-reader| ()
    #-clisp
    (set-packaged-macro-character #\{ '|{-reader|)
    
  #+clisp
  (progn
    (defun single-value-|{-reader| (stream char &aux result)
      (setf result (|{-reader| stream char))
      result)
    (set-packaged-macro-character #\{ 'single-value-|{-reader|))))

(install-|{-reader|)


