From 8d61c3934b3394a7596d6967ce8dfbdbc70bdc67 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Thu, 29 Aug 2013 14:50:37 +0200 Subject: [PATCH] Simpler printer --- src/boot.lisp | 7 +- src/print.lisp | 372 ++++++++++++++++++++++++++++++------------------------ tests/print.lisp | 35 +++++ 3 files changed, 248 insertions(+), 166 deletions(-) diff --git a/src/boot.lisp b/src/boot.lisp index 856879f..1b3541c 100644 --- a/src/boot.lisp +++ b/src/boot.lisp @@ -485,12 +485,14 @@ `(let ((,value ,x)) (cond ,@(mapcar (lambda (c) - (if (eq (car c) t) + (if (find (car c) '(t otherwise)) `(t ,@(rest c)) `((,(ecase (car c) (integer 'integerp) (cons 'consp) (list 'listp) + (vector 'vectorp) + (character 'characterp) (sequence 'sequencep) (symbol 'symbolp) (function 'functionp) @@ -498,7 +500,8 @@ (array 'arrayp) (string 'stringp) (atom 'atom) - (null 'null)) + (null 'null) + (package 'packagep)) ,value) ,@(or (rest c) (list nil))))) diff --git a/src/print.lisp b/src/print.lisp index e262be1..146c173 100644 --- a/src/print.lisp +++ b/src/print.lisp @@ -1,8 +1,5 @@ ;;; print.lisp --- -;; Copyright (C) 2012, 2013 David Vazquez -;; Copyright (C) 2012 Raimon Grau - ;; JSCL is free software: you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation, either version 3 of the @@ -114,48 +111,39 @@ (concat result "|")) s)) -(defvar *print-escape* t) -(defvar *print-circle* nil) +#+jscl (defvar *print-escape* t) +#+jscl (defvar *print-circle* nil) -;;; FIXME: Please, rewrite this in a more organized way. -(defun !write-to-string (form &optional known-objects object-ids) - (when (and (not known-objects) *print-circle*) - ;; To support *print-circle* some objects must be tracked for - ;; sharing: conses, arrays and apparently-uninterned symbols. - ;; These objects are placed in an array and a parallel array is - ;; used to mark if they're found multiple times by assining them - ;; an id starting from 1. - ;; - ;; After the tracking has been completed the printing phas can - ;; begin: if an object has an id > 0 then #= is prefixed and - ;; the id is changed to negative. If an object has an id < 0 then - ;; #<-n># is printed instead of the object. - ;; - ;; The processing is O(n^2) with n = number of tracked - ;; objects. Hopefully it will become good enough when the new - ;; compiler is available. - (setf known-objects (make-array 100)) - (setf object-ids (make-array 100)) - (let ((n 0) - (sz 100) - (count 0)) +;; To support *print-circle* some objects must be tracked for sharing: +;; conses, arrays and apparently-uninterned symbols. These objects +;; are placed in an array and a parallel array is used to mark if +;; they're found multiple times by assining them an id starting from +;; 1. +;; +;; After the tracking has been completed the printing phase can begin: +;; if an object has an id > 0 then #= is prefixed and the id is +;; changed to negative. If an object has an id < 0 then #<-n># is +;; printed instead of the object. +;; +;; The processing is O(n^2) with n = number of tracked +;; objects. Hopefully it will become good enough when the new compiler +;; is available. +(defun scan-multiple-referenced-objects (form) + (let ((known-objects (make-array 0 :adjustable t :fill-pointer 0)) + (object-ids (make-array 0 :adjustable t :fill-pointer 0))) + (vector-push-extend nil known-objects) + (vector-push-extend 0 object-ids) + (let ((count 0)) (labels ((mark (x) (let ((i (position x known-objects))) - (if (= i -1) - (progn - (when (= n sz) - (setf sz (* 2 sz)) - ;; KLUDGE: storage vectors are an internal - ;; object which the printer should not know - ;; about. Use standard vector with fill - ;; pointers instead. - (resize-storage-vector known-objects sz) - (resize-storage-vector object-ids sz)) - (aset known-objects (1- (incf n)) x) - t) - (unless (aref object-ids i) - (aset object-ids i (incf count)) - nil)))) + (cond + ((null i) + (vector-push-extend x known-objects) + (vector-push-extend 0 object-ids) + t) + (t + (setf (aref object-ids i) (incf count)) + nil)))) (visit (x) (cond ((and x (symbolp x) (null (symbol-package x))) @@ -168,119 +156,183 @@ (when (mark x) (dotimes (i (length x)) (visit (aref x i)))))))) - (visit form)))) - (let ((prefix "")) - (when (and *print-circle* - (or (consp form) - (vectorp form) - (and form (symbolp form) (null (symbol-package form))))) - (let* ((ix (position form known-objects)) - (id (aref object-ids ix))) - (cond - ((and id (> id 0)) - (setf prefix (format nil "#~S=" id)) - (aset object-ids ix (- id))) - ((and id (< id 0)) - (return-from !write-to-string (format nil "#~S#" (- id))))))) - (concat prefix - (cond - ((null form) "NIL") - ((symbolp form) - (let ((name (symbol-name form)) - (package (symbol-package form))) - ;; Check if the symbol is accesible from the current package. It - ;; is true even if the symbol's home package is not the current - ;; package, because it could be inherited. - (if (eq form (find-symbol (symbol-name form))) - (escape-token (symbol-name form)) - ;; Symbol is not accesible from *PACKAGE*, so let us prefix - ;; the symbol with the optional package or uninterned mark. - (concat (cond - ((null package) "#") - ((eq package (find-package "KEYWORD")) "") - (t (escape-token (package-name package)))) - ":" - (if (and package - (eq (second (multiple-value-list - (find-symbol name package))) - :internal)) - ":" - "") - (escape-token name))))) - ((integerp form) (integer-to-string form)) - ((floatp form) (float-to-string form)) - ((characterp form) - (concat "#\\" - (case form - (#\newline "newline") - (#\space "space") - (otherwise (string form))))) - ((stringp form) (if *print-escape* - (lisp-escape-string form) - form)) - ((functionp form) - (let ((name #+jscl (oget form "fname") - #-jscl "noname")) - (if name - (concat "#") - (concat "#")))) - ((listp form) - (concat "(" - (join-trailing (mapcar (lambda (x) - (!write-to-string x known-objects object-ids)) - (butlast form)) " ") - (let ((last (last form))) - (if (null (cdr last)) - (!write-to-string (car last) known-objects object-ids) - (concat (!write-to-string (car last) known-objects object-ids) - " . " - (!write-to-string (cdr last) known-objects object-ids)))) - ")")) - ((vectorp form) - (let ((result "#(") - (sep "")) - (dotimes (i (length form)) - (setf result (concat result sep - (!write-to-string (aref form i) - known-objects - object-ids))) - (setf sep " ")) - (concat result ")"))) - ((packagep form) - (concat "#")) - (t "#"))))) + (visit form))) + (values known-objects object-ids))) + +;;; Write an integer to stream. +;;; TODO: Support for different basis. +(defun write-integer (value stream) + (write-string (integer-to-string value) stream)) + +;;; This version of format supports only ~A for strings and ~D for +;;; integers. It is used to avoid circularities. Indeed, it just +;;; ouputs to streams. +(defun simple-format (stream fmt &rest args) + (do ((i 0 (1+ i))) + ((= i (length fmt))) + (let ((char (char fmt i))) + (if (char= char #\~) + (let ((next (if (< i (1- (length fmt))) + (char fmt (1+ i)) + (error "`~~' appears in the last position of the format control string ~S." fmt)))) + (ecase next + (#\~ (write-char #\~ stream)) + (#\d (write-integer (pop args) stream)) + (#\a (write-string (pop args) stream))) + (incf i)) + (write-char char stream))))) + + +(defun write-aux (form stream known-objects object-ids) + (when *print-circle* + (let* ((ix (or (position form known-objects) 0)) + (id (aref object-ids ix))) + (cond + ((and id (> id 0)) + (simple-format stream "#~d=" id) + (setf (aref object-ids id) (- id))) + ((and id (< id 0)) + (simple-format stream "#~d#" (- id)) + (return-from write-aux))))) + (typecase form + ;; NIL + (null + (write-string "NIL" stream)) + ;; Symbols + (symbol + (let ((name (symbol-name form)) + (package (symbol-package form))) + ;; Check if the symbol is accesible from the current package. It + ;; is true even if the symbol's home package is not the current + ;; package, because it could be inherited. + (if (eq form (find-symbol (symbol-name form))) + (write-string (escape-token (symbol-name form)) stream) + ;; Symbol is not accesible from *PACKAGE*, so let us prefix + ;; the symbol with the optional package or uninterned mark. + (progn + (cond + ((null package) (write-char #\#)) + ((eq package (find-package "KEYWORD"))) + (t (write-char (escape-token (package-name package)) stream))) + (write-char #\: stream) + (let ((symbtype (second (multiple-value-list (find-symbol name package))))) + (when (and package (eq symbtype :internal)) + (write-char #\: stream))) + (write-string (escape-token name) stream))))) + ;; Integers + (integer + (write-integer form stream)) + ;; Floats + (float + (write-string (float-to-string form) stream)) + ;; Characters + (character + (write-string "#\\" stream) + (case form + (#\newline (write-string "newline" stream)) + (#\space (write-string "space" stream)) + (otherwise (write-char form stream)))) + ;; Strings + (string + (if *print-escape* + (write-string (lisp-escape-string form) stream) + (write-string form stream))) + ;; Functions + (function + (let ((name #+jscl (oget form "fname") + #-jscl nil)) + (if name + (simple-format stream "#" name) + (write-string "#" stream)))) + ;; Lists + (list + (write-char #\( stream) + (unless (null form) + (write-aux (car form) stream known-objects object-ids) + (do ((tail (cdr form) (cdr tail))) + ;; Stop on symbol OR if the object is already known when we + ;; accept circular printing. + ((or (atom tail) + (and *print-circle* + (let* ((ix (or (position tail known-objects) 0)) + (id (aref object-ids ix))) + (not (zerop id))))) + (unless (null tail) + (write-string " . " stream) + (write-aux tail stream known-objects object-ids))) + (write-char #\space stream) + (write-aux (car tail) stream known-objects object-ids))) + (write-char #\) stream)) + ;; Vectors + (vector + (write-string "#(" stream) + (when (plusp (length form)) + (write-aux (aref form 0) stream known-objects object-ids) + (do ((i 1 (1+ i))) + ((= i (length form))) + (write-char #\space stream) + (write-aux (aref form i) stream known-objects object-ids))) + (write-char #\) stream)) + ;; Packages + (package + (simple-format stream "#" (package-name form))) + ;; Others + (otherwise + (write-string "#" stream)))) -#+jscl -(fset 'write-to-string (fdefinition '!write-to-string)) +#+jscl +(defun write (form &key (stream *standard-output*)) + (write-aux form stream)) -(defun prin1-to-string (form) - (let ((*print-escape* t)) - (write-to-string form))) +(defun !write-to-string (form) + (with-output-to-string (output) + (multiple-value-bind (objs ids) + (scan-multiple-referenced-objects form) + (write-aux form output objs ids)))) +#+jscl (fset 'write-to-string (fdefinition '!write-to-string)) -(defun princ-to-string (form) - (let ((*print-escape* nil)) - (write-to-string form))) +#+jscl +(progn + + (defun prin1-to-string (form) + (let ((*print-escape* t)) + (write-to-string form))) -(defun terpri () - (write-char #\newline) - (values)) + (defun princ-to-string (form) + (let ((*print-escape* nil)) + (write-to-string form))) -(defun write-line (x) - (write-string x) - (terpri) - x) + (defun terpri () + (write-char #\newline) + (values)) + + (defun write-line (x) + (write-string x) + (terpri) + x) + + (defun warn (fmt &rest args) + (write-string "WARNING: ") + (apply #'format t fmt args) + (terpri)) + + (defun print (x) + (write-line (prin1-to-string x)) + x)) -(defun warn (fmt &rest args) - (write-string "WARNING: ") - (apply #'format t fmt args) - (terpri)) +;;; Format -(defun print (x) - (write-line (prin1-to-string x)) - x) +(defun format-special (chr arg) + (case (char-upcase chr) + (#\S (prin1-to-string arg)) + (#\A (princ-to-string arg)) + (#\D (princ-to-string arg)) + (t + (warn "~S is not implemented yet, using ~~S instead" chr) + (prin1-to-string arg)))) -(defun format (destination fmt &rest args) +(defun !format (destination fmt &rest args) (let ((len (length fmt)) (i 0) (res "") @@ -290,15 +342,15 @@ (if (char= c #\~) (let ((next (char fmt (incf i)))) (cond - ((char= next #\~) - (concatf res "~")) - ((char= next #\%) - (concatf res (string #\newline))) - ((char= next #\*) - (pop arguments)) - (t - (concatf res (format-special next (car arguments))) - (pop arguments)))) + ((char= next #\~) + (concatf res "~")) + ((char= next #\%) + (concatf res (string #\newline))) + ((char= next #\*) + (pop arguments)) + (t + (concatf res (format-special next (car arguments))) + (pop arguments)))) (setq res (concat res (string c)))) (incf i))) (if destination @@ -306,12 +358,4 @@ (write-string res) nil) res))) - -(defun format-special (chr arg) - (case (char-upcase chr) - (#\S (prin1-to-string arg)) - (#\A (princ-to-string arg)) - (#\D (princ-to-string arg)) - (t - (warn "~S is not implemented yet, using ~~S instead" chr) - (prin1-to-string arg)))) +#+jscl (fset 'format (fdefinition '!format)) diff --git a/tests/print.lisp b/tests/print.lisp index 8d58c3c..c159e56 100644 --- a/tests/print.lisp +++ b/tests/print.lisp @@ -16,3 +16,38 @@ (and (symbolp x) (equal (symbol-name x) "1E+2")))) (test (let ((x (read-from-string (prin1-to-string '1E+)))) (and (symbolp x) (equal (symbol-name x) "1E+")))) + + + +;;; Printing strings +(test (string= "\"foobar\"" (write-to-string "foobar"))) +(test (string= "\"foo\\\"bar\"" (write-to-string "foo\"bar"))) + +;;; Printing vectors +(test (string= "#()" (write-to-string #()))) +(test (string= "#(1)" (write-to-string #(1)))) +(test (string= "#(1 2 3)" (write-to-string #(1 2 3)))) + +;;; Lists +(test (string= "NIL" (write-to-string '()))) +(test (string= "(1)" (write-to-string '(1)))) +(test (string= "(1 2 3)" (write-to-string '(1 2 3)))) +(test (string= "(1 2 . 3)" (write-to-string '(1 2 . 3)))) +(test (string= "(1 2 3)" (write-to-string '(1 2 3)))) +(test (string= "((1 . 2) 3)" (write-to-string '((1 . 2) 3)))) +(test (string= "((1) 3)" (write-to-string '((1) 3)))) + +;;; Circular printing +(let ((vector #(1 2 nil))) + (setf (aref vector 2) vector) + (test (string= "#1=#(1 2 #1#)" + (let ((*print-circle* t)) + (write-to-string vector))))) + +(let ((list '(1))) + (setf (cdr list) list) + (test (string= "#1=(1 . #1#)" + (let ((*print-circle* t)) + (write-to-string list))))) + + -- 1.7.10.4