From: "Iñaki Baz Castillo" <ibc@...>
Date: 2009-08-02T19:29:04+09:00
Subject: Re: RUBY vs COMMON LISP

El Domingo, 2 de Agosto de 2009, fft1976 escribió:
> > (defstruct character-description
> >   non-terminating-p
> >   reader-macro
> >   dispatching-macro-characters)
> >
> > (defstruct (simple-readtable (:constructor %make-simple-readtable))
> >   (default-character-description (make-character-description))
> >   (macro-characters (make-hash-table))
> >   (parse-token (function identity))
> >   (whitespaces  #(#\space #\tab #\newline #\linefeed #\return #\page
> > #\vt)))
> >
> > (defun simple-get-macro-character (character &optional (readtable
> > *simple-readtable*)) (let ((description (or (gethash character
> > (simple-readtable-macro-characters readtable))
> > (simple-readtable-default-character-description readtable)))) (values
> > (character-description-reader-macro description)
> >             (character-description-non-terminating-p description))))
> >
> > (defun simple-set-macro-character (character function &optional
> > non-terminating-p (readtable *simple-readtable*)) (setf (gethash
> > character (simple-readtable-macro-characters readtable))
> > (make-character-description :non-terminating-p non-terminating-p
> > :reader-macro function))
> >   't)
> >
> > (defun simple-get-dispatch-macro-character (character subchar
> >                                             &optional (readtable
> > *simple-readtable*)) (setf subchar (char-upcase subchar))
> >   (let ((description (gethash character
> > (simple-readtable-macro-characters readtable)))) (unless (and description
> >                  (character-description-dispatching-macro-characters
> > description)) (error "#\\~C is not a dispatching macro character"
> > character)) (gethash subchar
> > (character-description-dispatching-macro-characters description))))
> >
> > (defun simple-set-dispatch-macro-character (character subchar function
> >                                             &optional (readtable
> > *simple-readtable*)) (setf subchar (char-upcase subchar))
> >   (let ((description (gethash character
> > (simple-readtable-macro-characters readtable)))) (when (or (null
> > description)
> >               (null (character-description-dispatching-macro-characters
> > description))) (setf (gethash character
> > (simple-readtable-macro-characters readtable))
> > (make-character-description :non-terminating-p t
> >                                         :reader-macro (function
> > simple-reader-dispatching-macro) :dispatching-macro-characters
> > (make-hash-table))))) (let ((description (gethash character
> > (simple-readtable-macro-characters readtable)))) (setf (gethash subchar
> >  (character-description-dispatching-macro-characters description))
> > function))
> >   't)
> >
> > (defun simple-reader-dispatching-macro (character stream)
> >   (let* ((subchar  (read-char stream))
> >          (macro    (simple-get-dispatch-macro-character character
> > subchar))) (assert macro () "~C~C is not a dispatching macro" character
> > subchar) (funcall macro character subchar stream)))
> >
> > (defun simple-read-vector-dmacro (char subchar stream)
> >   (declare (ignore char))
> >   (let ((contents (simple-read-list-macro subchar stream)))
> >     (coerce contents 'vector)))
> >
> > (defvar *character-names* (list (cons "SPACE"    (code-char 32))
> >                                 (cons "NEWLINE"  (code-char 10))
> >                                 (cons "RETURN"   (code-char 13))
> >                                 (cons "PAGE"     (code-char 12))
> >                                 (cons "VT"       (code-char 11))
> >                                 (cons "LINEFEED" (code-char 10))
> >                                 (cons "TAB"      (code-char 9)))
> >   "An a-list mapping character names to characters.")
> >
> > (defun simple-read-character-dmacro (char subchar stream)
> >   (declare (ignore char subchar))
> >   (let ((object (read-char stream)))
> >     (if (alpha-char-p (peek-char nil stream nil #\space))
> >         (loop
> >            :with buffer = (make-array 8 :element-type 'character
> > :adjustable t :fill-pointer 1 :initial-element object)
> >            :do (vector-push-extend (read-char stream) buffer)
> >            :while (alpha-char-p (peek-char nil stream nil #\space))
> >            :finally (return (or (cdr (assoc (string-upcase buffer)
> > *character-names* :test (function string=))) (aref buffer 0))))
> >         object)))
> >
> > (defun simple-parse-token (buffer)
> >   ;; We only deal with integers, keywords and symbols.
> >   (or (ignore-errors (parse-integer buffer :junk-allowed nil))
> >       (if (char= #\: (aref buffer 0))
> >           (intern (string-upcase (subseq buffer (position #\: buffer
> > :test (function char/=)))) "KEYWORD")
> >           ;; We don't deal with other packages in this simple
> > parse-token. (intern (string-upcase buffer)))))
> >
> > (defun simple-read-quote-macro (character stream)
> >   (declare (ignore character))
> >   (list 'quote (simple-read stream)))
> >
> > (defun simple-read-list-macro (character stream)
> >   (declare (ignore character))
> >   (loop
> >      :until (char= #\) (peek-char t stream))
> >      :collect (simple-read stream)
> >      :finally (read-char stream)))
> >
> > (defun simple-read-string-macro (character stream)
> >   (handler-case
> >       (loop
> >          :with buffer = (make-array 8 :element-type 'character
> > :adjustable t :fill-pointer 0) :for ch = (read-char stream)
> >          :until (char= character ch)
> >          :do (vector-push-extend (if (char= #\\ ch)
> >                                      (read-char stream)
> >                                      ch)
> >                                  buffer)
> >          :finally (return (copy-seq buffer)))))
> >
> > (defun simple-read-comment-macro (character stream)
> >   (declare (ignore character))
> >   (read-line stream)
> >   (values))
> >
> > (defun make-simple-readtable ()
> >   (let ((readtable
> >          (%make-simple-readtable
> >           :default-character-description (make-character-description
> > :non-terminating-p t) :parse-token (function simple-parse-token))))
> >     (simple-set-macro-character #\( (function simple-read-list-macro)    
> > nil readtable) (simple-set-macro-character #\) nil                      
> >             nil readtable) (simple-set-macro-character #\' (function
> > simple-read-quote-macro)    nil readtable) (simple-set-macro-character
> > #\" (function simple-read-string-macro)   nil readtable)
> > (simple-set-macro-character #\; (function simple-read-comment-macro)  nil
> > readtable) (simple-set-dispatch-macro-character #\# #\\ (function
> > simple-read-character-dmacro) readtable)
> > (simple-set-dispatch-macro-character #\# #\( (function
> > simple-read-vector-dmacro)    readtable) readtable))
> >
> > (defparameter *simple-readtable* (make-simple-readtable))
> >
> > (defun simple-read (&optional (stream *standard-input*) (eof-error-p t)
> > eof-value) (peek-char t stream nil)
> >   (let ((char (read-char stream nil nil)))
> >     (cond
> >       (char
> >        (multiple-value-bind (macro non-terminating-p)
> > (simple-get-macro-character char) (if macro
> >              (let ((object (multiple-value-list (funcall macro char
> > stream)))) (if object (first object) (simple-read stream eof-error-p
> > eof-value))) (loop
> >                 :with buffer = (make-array 8 :element-type 'character
> > :adjustable t :fill-pointer 0) :for ch = (peek-char nil stream nil
> > #\space)
> >                 :initially (vector-push-extend char buffer)
> >                 :until (or (position ch (simple-readtable-whitespaces
> > *simple-readtable*)) (not (nth-value 1 (simple-get-macro-character ch))))
> > :do (vector-push-extend (read-char stream eof-error-p eof-value) buffer)
> > :finally (return (funcall (simple-readtable-parse-token
> > *simple-readtable*) buffer))))))
> >       (eof-error-p (error 'end-of-file :stream stream))
> >       (t eof-value))))


Is the above a language or a list of home tasks?

-- 
Iñaki Baz Castillo <ibc@aliax.net>