; .EnTete "Le-Lisp (c) version 15.2" " " "Les objets circulaires"
; .EnPied " " "%" " "
; .SuperTitre "Les objets circulaires"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: libcir.ll,v 4.3 88/11/24 15:00:55 gallou Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'libcir))
; Tous les symboles pre'ce'de's de : seront dans le package libcir
(defvar #:sys-package:colon 'libcir)
(add-feature 'libcir)
; le drapeau du traitement particulier des packages
(ifn (boundp ':package-parano) (defvar :package-parano ()))
; Ajout de DEFVAR supple'mentaires pour indiquer que l'utilisation de
; variables dynamiques nest pas fortuite.
(defvar :old) ; le nouveau label lu.
(defvar :new) ; l'objet e'tiquete' par ce label.
(defvar :seen) ; pour imprimer ou copier, me'morise
; les labels de'ja` visite's
; .Section "Les impressions : cirprint, cirprin et cirprinflush"
(de cirprint (:x) (cirprin :x) (print))
(de cirprinflush (:x) (cirprin :x) (prinflush))
; une passe pour repe'rer les boucles, une autre pour imprimer
; avec la syntaxe #<n>= et #<n>#
(de cirprin (:x)
(let ((:shared))
(let ((:seen)) (:sweep :x))
(setq :shared (nreverse :shared))
(if :shared (let ((:seen)) (:prin :x)) (prin :x))))
(de :sweep (:x)
(cond
((and (consp :x) (:unshared :x))
(:sweep (car :x)) (:sweep (cdr :x)))
((and (stringp :x) (:unshared :x))
(:sweep (typestring :x)))
((and (vectorp :x) (:unshared :x))
(mapvector ':sweep :x)
(if (neq (typevector :x) 'vector) (:sweep (typevector :x))))
((and :package-parano (symbolp :x) (packagecell :x) (:unshared :x))
(:sweep (packagecell :x)))))
(de :unshared (:x)
(let ((:is-seen (memq :x :seen)))
(ifn :is-seen (newl :seen :x))
(if (and :is-seen (not (memq :x :shared))) (newl :shared :x))
(not :is-seen)))
(de :prin (:x)
(let ((:is-shared (memq :x :shared)))
(if :is-shared
(:prin-sharp :x (length :is-shared) (memq :x :seen))
(:prin1 :x))))
(de :prin-sharp (:x :n :not-first)
(if :not-first
(:prin-one (cons '#/# (nconc1 (pname :n) '#/#)))
(:prin-one (cons '#/# (nconc1 (pname :n) '#/=)))
(newl :seen :x)
(:prin1 :x)))
(de :prin1 (:x)
(cond
((tconsp :x)
(:prin-one '(#/# #/())
(:prin (car :x))
(:prin-cdr (cdr :x)))
((consp :x)
(princn #/() (:prin (car :x)) (:prin-cdr (cdr :x)))
((vectorp :x)
(when (neq (typevector :x) 'vector)
(:prin-one '(#/# #/:))
(:prin (typevector :x))
(:prin-one '(#/:)))
(:prin-one '(#/# #/[))
(mapvector (lambda (:x) (:prin :x) (princn #\sp)) ; pas parfait
:x)
(princn #/]))
((and (stringp :x) (neq (typestring :x) 'string))
(:prin-one '(#/# #/:))
(:prin (typestring :x))
(:prin-one '(#/:))
(prin (catenate :x "")))
((and :package-parano (symbolp :x) (packagecell :x))
(:prin-one '(#/# #/:))
(:prin (packagecell :x))
(princn #/:)
(prin (symbol () :x)))
(t (prin :x))))
(de :prin-cdr (:x)
(cond
((null :x) (princn #/))) ; (
((or (atomp :x) (tconsp :x) (memq :x :shared))
(:prin-one '(#\sp #/. #\sp))
(:prin :x)
(princn #/))) ; (
(t (princn #\sp) (:prin (car :x)) (:prin-cdr (cdr :x)))))
(de :prin-one (:l)
;; print a list of character codes.
;; Ensure that all the charcodes are printed on the same line.
(when (ge (length :l) (sub (rmargin) (outpos)))
(terpri))
(mapc 'princn :l))
; .Section "Lecture de structures circulaires: read"
; on se contente de #<n>= et #<n>#
; a` la lecture, on alloue un cons unique qu'on remplace
; attention, la structure traite'e peut avoir des boucles
(defvar :shared)
(defvar :shared-length)
(defsharp |=| (:n)
(ifn (and (boundp ':shared) (vectorp :shared))
(setq :shared #[()] :shared-length 1))
(while (>= :n :shared-length) (:double))
(let ((:old (ncons :n)))
(vset :shared :n :old)
(let ((:new (read))(:seen))
(vset :shared :n :new)
(:replace :new)
(list :new))))
(defsharp |#| (:n)
(list (vref :shared :n)))
(de :double ()
(let ((:dbnew (makevector (+ :shared-length :shared-length) ())))
(bltvector :dbnew 0 :shared 0 :shared-length)
(setq :shared :dbnew :shared-length
(+ :shared-length :shared-length))))
(de :replace (:x)
(cond
((memq :x :seen))
((consp :x)
(newl :seen :x)
(if (eq (car :x) :old) (rplaca :x :new) (:replace (car :x)))
(if (eq (cdr :x) :old) (rplacd :x :new) (:replace (cdr :x))))
((and :package-parano (symbolp :x) (packagecell :x))
(newl :seen :x)
(if (eq (packagecell :x) :old)
(packagecell :x :new)
(:replace (packagecell :x))))
((and (stringp :x) (neq (typestring :x) 'string))
(newl :seen :x)
(if (eq (typestring :x) :old)
(typestring :x :new)
(:replace (typestring :x))))
((vectorp :x)
(newl :seen :x)
(if (neq (typevector :x) 'vector)
(if (eq (typevector :x) :old)
(typevector :x :new)
(:replace (typevector :x))))
(for (:i 0 1 (1- (vlength :x)))
(if (eq (vref :x :i) :old)
(vset :x :i :new)
(:replace (vref :x :i)))))))
; equal (pour les structures, on prend eq pour comparer les types ?)
(de cirnequal (:x :y) (not (cirequal :x :y)))
(de cirequal (:x :y)
(tag :no
(let ((:seen1)(:seen2))
(:equal :x :y) t)))
(de :equal (:x :y)
(cond
((eq :x :y))
((memq :x :seen1)
(ifn (eq (length (memq :x :seen1)) (length (memq :y :seen2)))
(exit :no ())))
((tconsp :x)
(ifn (tconsp :y) (exit :no ()))
(newl :seen1 :x) (newl :seen2 :y)
(:equal (car :x) (car :y))
(:equal (cdr :x) (cdr :y)))
((consp :x)
(ifn (and (consp :y) (not (tconsp :y))) (exit :no ()))
(newl :seen1 :x) (newl :seen2 :y)
(:equal (car :x) (car :y))
(:equal (cdr :x) (cdr :y)))
((vectorp :x) ; le cas des chaines est couvert par equal
(ifn (and (vectorp :y) (eq (vlength :x) (vlength :y)))
(exit :no ()))
(ifn (eq (typevector :x) (typevector :y)) (exit :no ()))
(newl :seen1 :x) (newl :seen2 :y)
(for (:i 0 1 (1- (vlength :x)))
(:equal (vref :x :i) (vref :y :i))))
((and :package-parano (symbolp :x) (packagecell :x))
(ifn (and (symbolp :y) (packagecell :y)) (exit :no ()))
(newl :seen1 :x) (newl :seen2 :y)
(:equal (packagecell :x) (packagecell :y)))
(t (ifn (equal :x :y) (exit :no ())))))
; copy
; on procede par modification physique a partir du squelette
; on ne recopie pas les symboles aux packages pathologiques
(de circopy (:x)
(let ((:seen)(:copied))
(:copy :x)))
(de :copy (:x)
(cond
((memq :x :seen)
(car (lastn (length (memq :x :seen)) :copied)))
((tconsp :x)
(newl :seen :x)
(let ((:cpnew (tcons () ())))
(newl :copied :cpnew)
(rplaca :cpnew (:copy (car :x)))
(rplacd :cpnew (:copy (cdr :x)))
:cpnew))
((consp :x)
(newl :seen :x)
(let ((:cpnew (ncons ())))
(newl :copied :cpnew)
(rplaca :cpnew (:copy (car :x)))
(rplacd :cpnew (:copy (cdr :x)))
:cpnew))
((vectorp :x)
(newl :seen :x)
(let ((:cpnew (makevector (vlength :x) ())))
(newl :copied :cpnew)
(for (:i 0 1 (1- (vlength :x)))
(vset :cpnew :i (:copy (vref :x :i))))
(if (neq (typevector :x) 'vector)
(typevector :cpnew (typevector :x)))
:cpnew))
(t (copy :x))))
; pour les tests
#|
(setq a '(1 2 3))
(rplaca (cdr a) (cdr a))
(rplacd (cddr a) a)
(cirprint a) ; -> #1=(1 . #2=(#2# #1#))
(cirequal a (read))
'#1=(1 . #2=(#2# #1#))
(cirequal a (circopy a))
|#