From fc42fe56a57eace2dbdb31574c2e161f0eacf839 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Wed, 15 Jun 2005 13:00:39 +0000
Subject: Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0
---
 src/bigloo/read.scm | 482 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 482 insertions(+)
 create mode 100644 src/bigloo/read.scm

(limited to 'src/bigloo/read.scm')

diff --git a/src/bigloo/read.scm b/src/bigloo/read.scm
new file mode 100644
index 0000000..91cd345
--- /dev/null
+++ b/src/bigloo/read.scm
@@ -0,0 +1,482 @@
+;*=====================================================================*/
+;*    serrano/prgm/project/skribe/src/bigloo/read.scm                  */
+;*    -------------------------------------------------------------    */
+;*    Author      :  Manuel Serrano                                    */
+;*    Creation    :  Tue Dec 27 11:16:00 1994                          */
+;*    Last change :  Mon Nov  8 13:30:32 2004 (serrano)                */
+;*    -------------------------------------------------------------    */
+;*    Skribe's reader                                                  */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;*    Le module                                                        */
+;*---------------------------------------------------------------------*/
+(module skribe_read
+   (export (skribe-read . port)))
+
+;*---------------------------------------------------------------------*/
+;*    Global counteurs ...                                             */
+;*---------------------------------------------------------------------*/
+(define *par-open*  0)
+
+;*---------------------------------------------------------------------*/
+;*    Parenthesis mismatch (or unclosing) errors.                      */
+;*---------------------------------------------------------------------*/
+(define *list-error-level* 20)
+(define *list-errors*      (make-vector *list-error-level* #unspecified))
+(define *vector-errors*    (make-vector *list-error-level* #unspecified))
+
+;*---------------------------------------------------------------------*/
+;*    Control variables.                                               */
+;*---------------------------------------------------------------------*/
+(define *end-of-list*       (cons 0 0))
+(define *dotted-mark*       (cons 1 1))
+
+;*---------------------------------------------------------------------*/
+;*    skribe-reader-reset! ...                                         */
+;*---------------------------------------------------------------------*/
+(define (skribe-reader-reset!)
+   (set! *par-open* 0))
+
+;*---------------------------------------------------------------------*/
+;*    read-error ...                                                   */
+;*---------------------------------------------------------------------*/
+(define (read-error msg obj port)
+   (let* ((obj-loc (if (epair? obj)
+		       (match-case (cer obj)
+			  ((at ?fname ?pos ?-)
+			   pos)
+			  (else
+			   #f))
+		       #f))
+	  (loc (if (number? obj-loc)
+		   obj-loc
+		   (cond
+		      ((>fx *par-open* 0)
+		       (let ((open-key (-fx *par-open* 1)))
+			  (if (<fx open-key (vector-length *list-errors*))
+			      (vector-ref *list-errors* open-key)
+			      #f)))
+		      (else
+		       #f)))))
+      (if (fixnum? loc)
+	  (error/location "skribe-read" msg obj (input-port-name port) loc)
+	  (error "skribe-read" msg obj))))
+
+;*---------------------------------------------------------------------*/
+;*    make-list! ...                                                   */
+;*---------------------------------------------------------------------*/
+(define (make-list! l port)
+   (define (reverse-proper-list! l)
+      (let nr ((l l)
+	       (r '()))
+	 (cond
+	    ((eq? (car l) *dotted-mark*)
+	     (read-error "Illegal pair" r port))
+	    ((null? (cdr l))
+	     (set-cdr! l r)
+	     l)
+	    (else
+	     (let ((cdrl (cdr l)))
+		(nr cdrl
+		    (begin (set-cdr! l r)
+			   l)))))))
+   (define (reverse-improper-list! l)
+      (let nr ((l (cddr l))
+	       (r (car l)))
+	 (cond
+	    ((eq? (car l) *dotted-mark*)
+	     (read-error "Illegal pair" r port))
+	    ((null? (cdr l))
+	     (set-cdr! l r)
+	     l)
+	    (else
+	     (let ((cdrl (cdr l)))
+		(nr cdrl
+		    (begin (set-cdr! l r)
+			   l)))))))
+   (cond
+      ((null? l)
+       l)
+      ((and (pair? l) (pair? (cdr l)) (eq? (cadr l) *dotted-mark*))
+       (if (null? (cddr l))
+	   (car l)
+	   (reverse-improper-list! l)))
+      (else
+       (reverse-proper-list! l)))) 
+
+;*---------------------------------------------------------------------*/
+;*    make-at ...                                                      */
+;*---------------------------------------------------------------------*/
+(define (make-at name pos)
+   (cond-expand
+      ((or bigloo2.4 bigloo2.5 bigloo2.6)
+       `(at ,name ,pos _))
+      (else
+       `(at ,name ,pos))))
+
+;*---------------------------------------------------------------------*/
+;*    collect-up-to ...                                                */
+;*    -------------------------------------------------------------    */
+;*    The first pair of the list is special because of source file     */
+;*    location. We want the location to be associated to the first     */
+;*    open parenthesis, not the last character of the car of the list. */
+;*---------------------------------------------------------------------*/
+(define-inline (collect-up-to ignore kind port)
+   (let ((name (input-port-name port)))
+      (let* ((pos  (input-port-position port))
+	     (item (ignore)))
+	 (if (eq? item *end-of-list*)
+	     '()
+	     (let loop ((acc (econs item '() (make-at name pos))))
+		(let ((item (ignore)))
+		   (if (eq? item *end-of-list*)
+		       acc
+		       (loop (let ((new-pos  (input-port-position port)))
+				(econs item
+				       acc
+				       (make-at name new-pos)))))))))))
+
+;*---------------------------------------------------------------------*/
+;*    read-quote ...                                                   */
+;*---------------------------------------------------------------------*/
+(define (read-quote kwote port ignore)
+   (let* ((pos (input-port-position port))
+	  (obj (ignore)))
+      (if (or (eof-object? obj) (eq? obj *end-of-list*))
+	  (error/location "read"
+			  "Illegal quotation"
+			  kwote
+			  (input-port-name port)
+			  pos))
+      (econs kwote
+	     (cons obj '())
+	     (make-at (input-port-name port) pos))))
+
+;*---------------------------------------------------------------------*/
+;*    *sexp-grammar* ...                                               */
+;*---------------------------------------------------------------------*/
+(define *sexp-grammar*
+   (regular-grammar ((float    (or (: (* digit) "." (+ digit))
+			 	   (: (+ digit) "." (* digit))))
+		     (letter   (in ("azAZ") (#a128 #a255)))
+		     (special  (in "!@~$%^&*></-_+\\=?.:{}"))
+		     (kspecial (in "!@~$%^&*></-_+\\=?."))
+		     (quote    (in "\",'`"))
+		     (paren    (in "()"))
+		     (id       (: (* digit)
+				  (or letter special)
+				  (* (or letter special digit (in ",'`")))))
+		     (kid      (: (* digit)
+				  (or letter kspecial)
+				  (* (or letter kspecial digit (in ",'`")))))
+		     (blank    (in #\Space #\Tab #a012 #a013)))
+      
+      ;; newlines
+      ((+ #\Newline)
+       (ignore))
+      
+      ;; blank lines
+      ((+ blank)
+       (ignore))
+      
+      ;; comments
+      ((: ";" (* all))
+       (ignore))
+      
+      ;; the interpreter header or the dsssl named constants
+      ((: "#!" (+ (in letter)))
+       (let* ((str (the-string)))
+	  (cond
+	     ((string=? str "#!optional")
+	      boptional)
+	     ((string=? str "#!rest")
+	      brest)
+	     ((string=? str "#!key")
+	      bkey)
+	     (else
+	      (ignore)))))
+      
+      ;; characters
+      ((: (uncase "#a") (= 3 digit))
+       (let ((string (the-string)))
+	  (if (not (=fx (the-length) 5))
+	      (error/location "skribe-read"
+			      "Illegal ascii character"
+			      string
+			      (input-port-name     (the-port))
+			      (input-port-position (the-port)))
+	      (integer->char (string->integer (the-substring 2 5))))))
+      ((: "#\\" (or letter digit special (in "|#; []" quote paren)))
+       (string-ref (the-string) 2))
+      ((: "#\\" (>= 2 letter))
+       (let ((char-name (string->symbol
+			 (string-upcase!
+			  (the-substring 2 (the-length))))))
+	  (case char-name
+	     ((NEWLINE)
+	      #\Newline)
+	     ((TAB)
+	      #\tab)
+	     ((SPACE)
+	      #\space)
+	     ((RETURN)
+	      (integer->char 13))
+	     (else
+	      (error/location "skribe-read"
+			      "Illegal character"
+			      (the-string)
+			      (input-port-name     (the-port))
+			      (input-port-position (the-port)))))))
+      
+      ;; ucs-2 characters
+      ((: "#u" (= 4 xdigit))
+       (integer->ucs2 (string->integer (the-substring 2 6) 16)))
+      
+      ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
+       (let ((str (the-substring 1 (-fx (the-length) 1))))
+	  (let ((str (the-substring 0 (-fx (the-length) 1))))
+	     (escape-C-string str))))
+      ;; ucs2 strings
+      ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
+       (let ((str (the-substring 3 (-fx (the-length) 1))))
+  	  (utf8-string->ucs2-string str)))
+      
+      ;; fixnums
+      ((: (? (in "-+")) (+ digit))
+       (the-fixnum))
+      ((: "#o" (? (in "-+")) (+ (in ("07"))))
+       (string->integer (the-substring 2 (the-length)) 8))
+      ((: "#d" (? (in "-+")) (+ (in ("09"))))
+       (string->integer (the-substring 2 (the-length)) 10))
+      ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af"))))))
+       (string->integer (the-substring 2 (the-length)) 16))
+      ((: "#e" (? (in "-+")) (+ digit))
+       (string->elong (the-substring 2 (the-length)) 10))
+      ((: "#l" (? (in "-+")) (+ digit))
+       (string->llong (the-substring 2 (the-length)) 10))
+      
+      ;; flonum
+      ((: (? (in "-+"))
+	  (or float
+	      (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit))))
+       (the-flonum))
+      
+      ;; doted pairs
+      ("."
+       (if (<=fx *par-open* 0)
+	   (error/location "read"
+			   "Illegal token"
+			   #\.
+			   (input-port-name     (the-port))
+			   (input-port-position (the-port)))
+	   *dotted-mark*))
+      
+      ;; unspecified and eof-object
+      ((: "#" (in "ue") (+ (in "nspecified-objt")))
+       (let ((symbol (string->symbol
+		      (string-upcase!
+		       (the-substring 1 (the-length))))))
+	  (case symbol
+	     ((UNSPECIFIED)
+	      unspec)
+	     ((EOF-OBJECT)
+	      beof)
+	     (else
+	      (error/location "read"
+			      "Illegal identifier"
+			      symbol
+			      (input-port-name     (the-port))
+			      (input-port-position (the-port)))))))
+      
+      ;; booleans
+      ((: "#" (uncase #\t))
+       #t)
+      ((: "#" (uncase #\f))
+       #f)
+      
+      ;; keywords
+      ((or (: ":" kid) (: kid ":"))
+       ;; since the keyword expression is also matched by the id
+       ;; rule, keyword rule has to be placed before the id rule.
+       (the-keyword))
+      
+      ;; identifiers
+      (id
+       ;; this rule has to be placed after the rule matching the `.' char
+       (the-symbol))
+      ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|")
+       (if (=fx (the-length) 2)
+	   (the-symbol)
+	   (let ((str (the-substring 0 (-fx (the-length) 1))))
+	      (string->symbol (escape-C-string str)))))
+      
+      ;; quotations 
+      ("'"
+       (read-quote 'quote (the-port) ignore))
+      ("`"
+       (read-quote 'quasiquote (the-port) ignore))
+      (","
+       (read-quote 'unquote (the-port) ignore))
+      (",@"
+       (read-quote 'unquote-splicing (the-port) ignore))
+      
+      ;; lists
+      (#\(
+       ;; if possible, we store the opening parenthesis.
+       (if (and (vector? *list-errors*)
+		(<fx *par-open* (vector-length *list-errors*)))
+	   (vector-set! *list-errors*
+			*par-open*
+			(input-port-position (the-port))))
+       ;; we increment the number of open parenthesis
+       (set! *par-open* (+fx 1 *par-open*))
+       ;; and then, we compute the result list...
+       (make-list! (collect-up-to ignore "list" (the-port)) (the-port)))
+      (#\)
+       ;; we decrement the number of open parenthesis
+       (set! *par-open* (-fx *par-open* 1))
+       (if (<fx *par-open* 0)
+	   (begin
+	      (warning/location (input-port-name (the-port))
+				(input-port-position (the-port))
+				"read"
+				"Superfluous closing parenthesis `"
+				(the-string)
+				"'")
+	      (set! *par-open* 0)
+	      (ignore))
+	   *end-of-list*))
+
+      ;; list of strings
+      (#\[
+       (let ((exp (read/rp *text-grammar* (the-port))))
+	  (list 'quasiquote exp)))
+      
+      ;; vectors
+      ("#("
+       ;; if possible, we store the opening parenthesis.
+       (if (and (vector? *vector-errors*)
+		(<fx *par-open* (vector-length *vector-errors*)))
+	   (let ((pos (input-port-position (the-port))))
+	      (vector-set! *vector-errors* *par-open* pos)))
+       ;; we increment the number of open parenthesis
+       (set! *par-open* (+fx 1 *par-open*))
+       (list->vector (reverse! (collect-up-to ignore "vector" (the-port)))))
+      
+      ;; error or eof
+      (else
+       (let ((port (the-port))
+	     (char (the-failure)))
+	  (if (eof-object? char)
+	      (cond
+		 ((>fx *par-open* 0)
+		  (let ((open-key (-fx *par-open* 1)))
+		     (skribe-reader-reset!)
+		     (if (and (<fx open-key (vector-length *list-errors*))
+			      (fixnum? (vector-ref *list-errors* open-key)))
+			 (error/location "skribe-read"
+					 "Unclosed list"
+					 char
+					 (input-port-name port)
+					 (vector-ref *list-errors* open-key))
+			 (error "skribe-read"
+				"Unexpected end-of-file"
+				"Unclosed list"))))
+		 (else
+		  (reset-eof port)
+		  char))
+	      (error/location "skribe-read"
+			      "Illegal char"
+			      (illegal-char-rep char)
+			      (input-port-name     port)
+			      (input-port-position port)))))))
+
+;*---------------------------------------------------------------------*/
+;*    *text-grammar* ...                                               */
+;*    -------------------------------------------------------------    */
+;*    The grammar that parses texts (the [...] forms).                 */
+;*---------------------------------------------------------------------*/
+(define *text-grammar*
+   (regular-grammar ()
+      ((: (* (out ",[]\\")) #\])
+       (let* ((port (the-port))
+	      (name (input-port-name port))
+	      (pos (input-port-position port))
+	      (loc (make-at name pos))
+	      (item (the-substring 0 (-fx (the-length) 1))))
+	  (econs item '() loc)))
+      ((: (* (out ",[\\")) ",]")
+       (let* ((port (the-port))
+	      (name (input-port-name port))
+	      (pos (input-port-position port))
+	      (loc (make-at name pos))
+	      (item (the-substring 0 (-fx (the-length) 1))))
+	  (econs item '() loc)))
+      ((: (* (out ",[]\\")) #\,)
+       (let* ((port (the-port))
+	      (name (input-port-name port))
+	      (pos (input-port-position port))
+	      (loc (make-at name pos))
+	      (item (the-substring 0 (-fx (the-length) 1)))
+	      (sexp (read/rp *sexp-grammar* (the-port)))
+	      (rest (ignore)))
+	  (if (string=? item "")
+	      (cons (list 'unquote sexp) rest)
+	      (econs item (cons (list 'unquote sexp) rest) loc))))
+      ((or (+ (out ",[]\\"))
+	   (+ #\Newline)
+	   (: (* (out ",[]\\")) #\, (out "([]\\")))
+       (let* ((port (the-port))
+	      (name (input-port-name port))
+	      (pos (input-port-position port))
+	      (loc (make-at name pos))
+	      (item (the-string))
+	      (rest (ignore)))
+	  (econs item rest loc)))
+      ("\\\\"
+       (cons "\\" (ignore)))
+      ("\\n"
+       (cons "\n" (ignore)))
+      ("\\t"
+       (cons "\t" (ignore)))
+      ("\\]"
+       (cons "]" (ignore)))
+      ("\\["
+       (cons "[" (ignore)))
+      ("\\,"
+       (cons "," (ignore)))
+      (#\\
+       (cons "\\" (ignore)))
+      (else
+       (let ((c (the-failure))
+	     (port (the-port)))
+	  (define (err msg)
+	     (error/location "skribe-read-text"
+			     msg
+			     (the-failure)
+			     (input-port-name port)
+			     (input-port-position port)))
+	  (cond
+	     ((eof-object? c)
+	      (err "Illegal `end of file'"))
+	     ((char=? c #\[)
+	      (err "Illegal nested `[...]' form"))
+	     (else
+	      (err "Illegal string character")))))))
+
+;*---------------------------------------------------------------------*/
+;*    skribe-read ...                                                  */
+;*---------------------------------------------------------------------*/
+(define (skribe-read . input-port)
+   (cond
+      ((null? input-port)
+       (read/rp *sexp-grammar* (current-input-port)))
+      ((not (input-port? (car input-port)))
+       (error "read" "type `input-port' expected" (car input-port)))
+      (else
+       (let ((port (car input-port)))
+	  (if (closed-input-port? port)
+	      (error "read" "Illegal closed input port" port)
+	      (read/rp *sexp-grammar* port))))))
+
-- 
cgit v1.2.3