← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to pcl/impl/gold-hill/gold-patches.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
pcl/impl/gold-hill/gold-patches.lisp
 
1
;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*-
 
2
 
 
3
(in-package 'user)
 
4
 
 
5
(setq c::optimize-speed 3)
 
6
(setq c::optimize-safety 0)
 
7
(setq c::optimize-space 0)
 
8
 
 
9
(remprop 'macroexpand 'c::fdesc)
 
10
(remprop 'macroexpand-1 'c::fdesc)
 
11
 
 
12
 
 
13
;;; this is here to fix the printer so it will find the print
 
14
;;; functions on structures that have 'em.
 
15
 
 
16
(in-package 'lisp)
 
17
 
 
18
(defun %write-structure (struct output-stream print-vars level)
 
19
  (let* ((name (svref struct 0))
 
20
         (pfun (or (let ((temp (get name 'structure-descriptor)))
 
21
                     (and temp (dd-print-function temp)))
 
22
                   (get name :print-function))))
 
23
    (declare (symbol name))
 
24
    (cond
 
25
      (pfun
 
26
        (funcall pfun struct output-stream level))
 
27
      ((and (pv-level print-vars) (>= level (pv-level print-vars)))
 
28
       (write-char #\# output-stream))
 
29
      ((and (pv-circle print-vars)
 
30
            (%write-circle struct output-stream (pv-circle print-vars))))
 
31
      (t
 
32
       (let ((pv-length (pv-length print-vars))
 
33
             (pv-pretty (pv-pretty print-vars)))
 
34
         (when pv-pretty
 
35
           (pp-push-level pv-pretty))
 
36
         (incf level)
 
37
         (write-string "#s(" output-stream)
 
38
         (cond
 
39
          ((and pv-length (>= 0 pv-length))
 
40
           (write-string "..."))
 
41
          (t
 
42
           (%write-symbol name output-stream print-vars)
 
43
           (do ((i 0 (1+ i))
 
44
                (n 0)
 
45
                (slots (dd-slots (get name 'structure-descriptor))
 
46
                       (rest slots)))
 
47
               ((endp slots))
 
48
             (declare (fixnum i n) (list slots))
 
49
             (when pv-pretty
 
50
               (pp-insert-break pv-pretty *structure-keyword-slot-spec* t))
 
51
             (write-char #\space output-stream)
 
52
             (when (and pv-length (>= (incf n) pv-length))
 
53
               (write-string "..." output-stream)
 
54
               (return))
 
55
             (write-char #\: output-stream)
 
56
             (%write-symbol-name
 
57
              (symbol-name (dsd-name (first slots))) output-stream print-vars)
 
58
             (when pv-pretty
 
59
               (pp-insert-break pv-pretty *structure-data-slot-spec* nil))
 
60
             (write-char #\space output-stream)
 
61
             (when (and pv-length (>= (incf n) pv-length))
 
62
               (write-string "..." output-stream)
 
63
               (return))
 
64
             (%write-object
 
65
              (svref struct (dsd-index (first slots)))
 
66
              output-stream print-vars level))))
 
67
         (write-char #\) output-stream)
 
68
         (when pv-pretty
 
69
           (pp-pop-level pv-pretty)))))))
 
70
 
 
71
(eval-when (eval) (compile '%write-structure))
 
72
 
 
73
;;;
 
74
;;; Apparently, whoever implemented the TIME macro didn't consider that
 
75
;;; someone might want to use it in a non-null lexical environment.  Of
 
76
;;; course this fix is a loser since it binds a whole mess of variables
 
77
;;; around the evaluation of form, but it will do for now.
 
78
;;;
 
79
(in-package 'lisp)
 
80
 
 
81
(DEFmacro TIME (FORM)
 
82
  `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS)
 
83
     (FORMAT *trace-output* "~&Evaluating: ~A" ,form)
 
84
     ;; read the start time.
 
85
     (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START)
 
86
       (SYS::%SYSINT #X21 #X2C00 0 0 0))
 
87
     ;; Eval the form.
 
88
     (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form)))
 
89
     ;; Read the end time.
 
90
     (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH)
 
91
       (SYS::%SYSINT #X21 #X2C00 0 0 0))
 
92
     ;; Unpack start and end times.
 
93
     (SETQ S-HSEC (LOGAND START #X0FF)
 
94
           F-HSEC (LOGAND FINISH #X0FF)
 
95
           S-SEC (LSH START -8)
 
96
           F-SEC (LSH FINISH -8)
 
97
           S-MIN (LOGAND #X0FF S-MIN)
 
98
           F-MIN (LOGAND #X0FF F-MIN))
 
99
     (SETQ F-HSEC (- F-HSEC S-HSEC))                    ; calc hundreths
 
100
     (IF (MINUSP F-HSEC)
 
101
         (SETQ F-HSEC (+ F-HSEC 100)
 
102
               F-SEC (1- F-SEC)))
 
103
     (SETQ F-SEC (- F-SEC S-SEC))                       ; calc seconds
 
104
     (IF (MINUSP F-SEC)
 
105
         (SETQ F-SEC (+ F-SEC 60)
 
106
               F-MIN (1- F-MIN)))
 
107
     (SETQ F-MIN (- F-MIN S-MIN))                       ; calc minutes
 
108
     (IF (MINUSP F-MIN) (INCF F-MIN 60))
 
109
     (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%"
 
110
       F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC)
 
111
     (VALUES-LIST VALS)))
 
112
 
 
113
;;;
 
114
;;; Patch to PROGV
 
115
;;; 
 
116
(in-package sys::*compiler-package-load*)
 
117
 
 
118
;;; This is a fully portable (though not very efficient)
 
119
;;; implementation of PROGV as a macro.  It does its own special
 
120
;;; binding (shallow binding) by saving the original values in a
 
121
;;; list, and marking things that were originally unbound.
 
122
 
 
123
(defun PORTABLE-PROGV-BIND (symbol old-vals place-holder)
 
124
  (let ((val-to-save '#:value-to-save))
 
125
    `(let ((,val-to-save (if (boundp ,symbol)
 
126
                             (symbol-value ,symbol)
 
127
                             ,place-holder)))
 
128
       (if ,old-vals
 
129
           (rplacd (last ,old-vals) (ncons ,val-to-save))
 
130
           (setq ,old-vals (ncons ,val-to-save))))))
 
131
 
 
132
(defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder)
 
133
  (let ((val-to-restore '#:value-to-restore))
 
134
    `(let ((,val-to-restore (pop ,old-vals)))
 
135
       (if (eq ,val-to-restore ,place-holder)
 
136
           (makunbound ,symbol)
 
137
           (setf (symbol-value ,symbol) ,val-to-restore)))))
 
138
  
 
139
 
 
140
(deftransform PROGV PORTABLE-PROGV-TRANSFORM
 
141
              (symbols-form values-form &rest body)
 
142
  (let ((symbols-lst '#:symbols-list)
 
143
        (values-lst '#:values-list)
 
144
        (syms '#:symbols)
 
145
        (vals '#:values)
 
146
        (sym '#:symbol)
 
147
        (old-vals '#:old-values)
 
148
        (unbound-holder ''#:unbound-holder))
 
149
    `(let ((,symbols-lst ,symbols-form)
 
150
           (,values-lst ,values-form)
 
151
           (,old-vals nil))
 
152
       (unless (and (listp ,symbols-lst) (listp ,values-lst))
 
153
         (error "PROGV: Both symbols and values must be lists"))
 
154
       (unwind-protect
 
155
           (do ((,syms ,symbols-lst (cdr ,syms))
 
156
                (,vals ,values-lst (cdr ,vals))
 
157
                (,sym nil))
 
158
               ((null ,syms) (progn ,@body))
 
159
             (setq ,sym (car ,syms))
 
160
             (if (symbolp ,sym)
 
161
                 ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder)
 
162
                 (error "PROGV: Object to be bound not a symbol: ~S" ,sym))
 
163
             (if ,vals
 
164
                 (setf (symbol-value ,sym) (first ,vals))
 
165
                 (makunbound ,sym)))
 
166
         (dolist (,sym ,symbols-lst)
 
167
           ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder))))))
 
168