/[mcclim]/mcclim/bordered-output.lisp
ViewVC logotype

Diff of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by adejneka, Sat May 25 06:29:06 2002 UTC revision 1.2 by adejneka, Mon May 27 07:06:22 2002 UTC
# Line 35  Line 35 
35    (unless stream    (unless stream
36      (setq stream *standard-output*))      (setq stream *standard-output*))
37    (let ((continuation-name (gensym)))    (let ((continuation-name (gensym)))
38      `(flet ((,continuation-name () ,@body))      `(flet ((,continuation-name (,stream) ,@body))
39         (invoke-surrounding-output-with-border ,stream         (invoke-surrounding-output-with-border ,stream
40                                                #',continuation-name                                                #',continuation-name
41                                                ,@drawing-options))))                                                ,@drawing-options))))
# Line 43  Line 43 
43  (defun invoke-surrounding-output-with-border (stream cont  (defun invoke-surrounding-output-with-border (stream cont
44                                                &rest drawing-options                                                &rest drawing-options
45                                                &key (shape :rectangle) (move-cursor t))                                                &key (shape :rectangle) (move-cursor t))
46    (let ((record (with-new-output-record (stream)    (with-sheet-medium (medium stream)
47                    (funcall cont))))      (let ((record (with-new-output-record (stream)
48      (with-bounding-rectangle* (left top right bottom) record                      (funcall cont stream))))
49        (funcall (gethash shape *border-types*)        (with-bounding-rectangle* (left top right bottom) record
50                 :stream stream          (letf (((medium-transformation medium) +identity-transformation+))
51                 :record record            (funcall (gethash shape *border-types*)
52                 :left left :top top                     :stream stream
53                 :right right :bottom bottom                     :record record
54                 :allow-other-keys t))))                     :left left :top top
55                       :right right :bottom bottom
56                       :allow-other-keys t))))))
57    
58  (defmacro define-border-type (shape arglist &body body)  (defmacro define-border-type (shape arglist &body body)
59    (check-type arglist list)    (check-type arglist list)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5