source: trunk/ccl/level-1/l1-aprims.lisp @ 583

Last change on this file since 583 was 583, checked in by gb, 16 years ago

MAKE-ARRAY (and variants) track explicit array displacement (from
Bryan O'Connor).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; L1-aprims.lisp
18
19
20(in-package :ccl)
21
22
23(let* ((standard-initial-bindings ())
24       (standard-initial-bindings-lock (make-read-write-lock)))
25
26  (defun standard-initial-bindings ()
27    (with-read-lock (standard-initial-bindings-lock)
28      (copy-list standard-initial-bindings)))
29
30  (defun define-standard-initial-binding (symbol initform)
31    (setq symbol (require-type symbol 'symbol))
32    (%proclaim-special symbol)
33    (unless (boundp symbol)
34      (set symbol (funcall initform)))
35    (with-write-lock (standard-initial-bindings-lock)
36      (let* ((pair (assoc symbol standard-initial-bindings)))
37        (if pair
38          (setf (cdr pair) initform)
39          (push (cons symbol initform) standard-initial-bindings))))
40    (record-source-file symbol 'variable)
41    symbol))
42
43(def-standard-initial-binding *package*)
44
45(defun %badarg (arg type)
46  (%err-disp $XWRONGTYPE arg type))
47
48(defun atom (arg)
49  (not (consp arg)))
50
51(defun list (&rest args) args)
52
53(%fhave '%temp-list #'list)
54
55(defun list* (arg &rest others)
56  "Returns a list of the arguments with last cons a dotted pair"
57  (cond ((null others) arg)
58        ((null (cdr others)) (cons arg (car others)))
59        (t (do ((x others (cdr x)))
60               ((null (cddr x)) (rplacd x (cadr x))))
61           (cons arg others))))
62
63
64
65(defun funcall (fn &rest args)
66  (declare (dynamic-extent args))
67  (apply fn args))
68
69
70(defun apply (function arg &rest args)
71  "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
72  the manner of LIST*.  That is, a list is made of the values of all but the
73  last argument, appended to the value of the last argument, which must be a
74  list."
75  (declare (dynamic-extent args))
76  (cond ((null args)
77         (apply function arg))
78        ((null (cdr args))
79         (apply function arg (car args)))
80        (t (do* ((a1 args a2)
81                 (a2 (cdr args) (cdr a2)))
82                ((atom (cdr a2))
83                 (rplacd a1 (car a2))
84                 (apply function arg args))))))
85
86
87; This is not fast, but it gets the functionality that
88; Wood and possibly other code depend on.
89(defun applyv (function arg &rest other-args)
90  (declare (dynamic-extent other-args))
91  (let* ((other-args (cons arg other-args))
92         (last-arg (car (last other-args)))
93         (last-arg-length (length last-arg))
94         (butlast-args (nbutlast other-args))
95         (rest-args (make-list last-arg-length))
96         (rest-args-tail rest-args))
97    (declare (dynamic-extent other-args rest-args))
98    (dotimes (i last-arg-length)
99      (setf (car rest-args-tail) (aref last-arg i))
100      (pop rest-args-tail))
101    (apply function (nconc butlast-args rest-args))))
102
103; This is slow, and since %apply-lexpr isn't documented either,
104; nothing in the world should depend on it.  This is just being
105; anal retentive.  VERY anal retentive.
106
107(defun %apply-lexpr (function arg &rest args)
108  (cond ((null args) (%apply-lexpr function arg))
109        (t (apply function arg (nconc (nbutlast args)
110                                      (collect-lexpr-args (car (last args)) 0))))))
111
112
113(defun values-list (arg)
114  (apply #'values arg))
115
116
117
118(defun make-list (size &key initial-element)
119  (unless (and (typep size 'fixnum)
120               (>= (the fixnum size) 0))
121    (report-bad-arg size '(and fixnum unsigned-byte)))
122  (locally (declare (fixnum size))
123    (do* ((result '() (cons initial-element result)))
124        ((zerop size) result)
125      (decf size))))
126
127
128; copy-list
129
130(defun copy-list (list)
131  (if list
132    (let ((result (cons (car list) '()) ))
133      (do ((x (cdr list) (cdr x))
134           (splice result
135                   (%cdr (%rplacd splice (cons (%car x) '() ))) ))
136          ((atom x) (unless (null x)
137                      (%rplacd splice x)) result)))))
138
139(defun alt-list-length (l)
140  "Detect (and complain about) cirucular lists; allow any atom to
141terminate the list"
142  (do* ((n 0 (1+ n))
143        (fast l)
144        (slow l))
145       ((atom fast) n)
146    (declare (fixnum n))
147    (setq fast (cdr fast))
148    (if (logbitp 0 n)
149      (if (eq (setq slow (cdr slow)) fast)
150        (%err-disp $XIMPROPERLIST l)))))
151
152
153(defun last (list &optional (n 1))
154  (if (and (typep n 'fixnum)
155           (>= (the fixnum n) 0))
156    (locally (declare (fixnum n))
157      (do* ((checked-list list (cdr checked-list))
158            (returned-list list)
159            (index 0 (1+ index)))
160           ((atom checked-list) returned-list)
161        (declare (type index index))
162        (if (>= index n)
163          (pop returned-list))))
164    (if (and (typep n 'bignum)
165             (> n 0))
166      (require-type list 'list)
167      (report-bad-arg  n 'unsigned-byte))))
168
169
170
171
172
173(defun nthcdr (index list)
174  (if (and (typep index 'fixnum)
175           (>= (the fixnum index) 0))
176    (locally (declare (fixnum index))
177      (dotimes (i index list)
178        (when (null (setq list (cdr list))) (return))))
179    (progn
180      (unless (typep index 'unsigned-byte)
181        (report-bad-arg index 'unsigned-byte))
182      (do* ((n index (- n most-positive-fixnum)))
183           ((typep n 'fixnum) (nthcdr n list))
184        (unless (setq list (nthcdr most-positive-fixnum list))
185          (return))))))
186
187
188(defun nth (index list) (car (nthcdr index list)))
189
190
191(defun nconc (&rest lists)
192  (declare (dynamic-extent lists))
193  "Concatenates the lists given as arguments (by changing them)"
194  (do* ((top lists (cdr top)))
195       ((null top) nil)
196    (let* ((top-of-top (car top)))
197      (cond
198       ((consp top-of-top)
199        (let* ((result top-of-top)
200               (splice result))
201          (do* ((elements (cdr top) (cdr elements)))
202                 ((endp elements))
203            (let ((ele (car elements)))
204              (typecase ele
205                (cons (rplacd (last splice) ele)
206                      (setf splice ele))
207                (null (rplacd (last splice) nil))
208                (atom (if (cdr elements)
209                        (report-bad-arg ele 'list)
210                        (rplacd (last splice) ele)))
211                (t (report-bad-arg ele 'list)))))
212          (return result)))
213       ((null top-of-top) nil)
214       (t
215        (if (cdr top)
216          (report-bad-arg top-of-top 'list)
217          (return top-of-top)))))))
218
219
220(defvar %setf-function-names% (make-hash-table :weak t :test 'eq))
221
222(defun setf-function-name (sym)
223   (or (gethash sym %setf-function-names%)
224       (setf (gethash sym %setf-function-names%) (construct-setf-function-name sym))))
225
226
227
228                     
229
230(defconstant *setf-package* (or (find-package "SETF") (make-package "SETF" :use nil :external-size 1)))
231
232(defun construct-setf-function-name (sym)
233  (let ((pkg (symbol-package sym)))
234    (setq sym (symbol-name sym))
235    (if (null pkg)
236      (gentemp sym *setf-package*)
237      (values
238       (intern
239        ;I wonder, if we didn't check, would anybody report it as a bug?
240        (if (not (%str-member #\: (setq pkg (package-name pkg))))
241          (%str-cat pkg "::" sym)
242          (%str-cat (prin1-to-string pkg) "::" (princ-to-string sym)))
243        *setf-package*)))))
244
245(defun valid-function-name-p (name)
246  (if (symbolp name)                    ; Nil is a valid function name.  I guess.
247    (values t name)
248    (if (and (consp name)
249             (consp (%cdr name))
250             (null (%cddr name))
251             (symbolp (%cadr name)))
252      (values t (setf-function-name (%cadr name)))
253      ; What other kinds of function names do we care to support ?
254      (values nil nil))))
255
256; Why isn't this somewhere else ?
257(defun ensure-valid-function-name (name)
258  (multiple-value-bind (valid-p nm) (valid-function-name-p name)
259    (if valid-p nm (error "Invalid function name ~s." name))))
260
261
262; Returns index if char appears in string, else nil.
263
264(defun %str-member (char string &optional start end)
265  (let* ((base-string-p (typep string 'simple-base-string)))
266    (unless base-string-p
267      (setq string (require-type string 'simple-string)))
268    (unless (characterp char)
269      (setq char (require-type char 'character)))
270    (do* ((i (or start 0) (1+ i))
271            (n (or end (uvsize string))))
272           ((= i n))
273        (declare (fixnum i n) (optimize (speed 3) (safety 0)))
274        (if (eq (schar (the simple-base-string string) i) char)
275          (return i)))))
276
277
278
279; Returns index of elt in vector, or nil if it's not there.
280(defun %vector-member (elt vector)
281  (unless (typep vector 'simple-vector)
282    (report-bad-arg vector 'simple-vector))
283  (dotimes (i (the fixnum (length vector)))
284    (when (eq elt (%svref vector i)) (return i))))
285
286(defun logical-pathname-p (thing) (istruct-typep thing 'logical-pathname))
287
288(progn
289; It's back ...
290(defun list-nreverse (list)
291  (nreconc list nil))
292
293; We probably want to make this smarter so that less boxing
294; (and bignum/double-float consing!) takes place.
295
296(defun vector-nreverse (v)
297  (let* ((len (length v))
298         (middle (ash (the fixnum len) -1)))
299    (declare (fixnum middle len))
300    (do* ((left 0 (1+ left))
301          (right (1- len) (1- right)))
302         ((= left middle) v)
303      (declare (fixnum left right))
304      (rotatef (aref v left) (aref v right)))))
305   
306(defun nreverse (seq)
307  (seq-dispatch seq
308   (list-nreverse seq)
309   (vector-nreverse seq)))
310)
311
312(defun nreconc (x y)
313  "Returns (nconc (nreverse x) y)"
314  (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
315       (2nd x 1st)              ;2nd follows first down the list.
316       (3rd y 2nd))             ;3rd follows 2nd down the list.
317      ((atom 2nd) 3rd)
318    (rplacd 2nd 3rd)))
319
320(defun append (&lexpr lists)
321  (let* ((n (%lexpr-count lists)))
322    (declare (fixnum n))
323    (if (> n 0)
324      (if (= n 1)
325        (%lexpr-ref lists n 0)
326        (do* ((res (%lexpr-ref lists n 0) (append-2 res (%lexpr-ref lists n j)))
327              (j 1 (1+ j)))
328             ((= j n) res)
329          (declare (fixnum j)))))))
330
331
332
333
334
335
336
337(progn
338(defun list-reverse (l)
339  (do* ((new ()))
340       ((null l) new)
341    (push (pop l) new)))
342
343; Again, it's worth putting more work into this when the dust settles.
344(defun vector-reverse (v)
345  (let* ((len (length v))
346         (new (make-array (the fixnum len) :element-type (array-element-type v))))   ; a LOT more work ...
347    (declare (fixnum len))
348    (do* ((left 0 (1+ left))
349          (right (1- len) (1- right)))
350         ((= left len) new)
351      (declare (fixnum left right))
352      (setf (uvref new left)
353            (aref v right)))))
354
355(defun reverse (seq)
356  (seq-dispatch seq (list-reverse seq) (vector-reverse seq)))
357)
358
359(defun check-sequence-bounds (seq start end)
360  (let* ((length (length seq)))
361    (declare (fixnum length))
362    (if (not end)
363      (setq end length)
364      (unless (typep end 'fixnum)
365        (report-bad-arg end 'fixnum)))
366    (unless (typep start 'fixnum)
367      (report-bad-arg start 'fixnum))
368    (locally (declare (fixnum start end))
369      (cond ((> end length)
370             (report-bad-arg end `(integer 0 (,length))))
371            ((< start 0)
372             (report-bad-arg start `(integer 0)))
373            ((> start end)
374             (report-bad-arg start `(integer 0 ,end)))
375            (t end)))))
376 
377
378(defun byte-length (string &optional  (start 0) end)
379  (setq end (check-sequence-bounds string start end))
380  (- end start))
381
382
383
384(defun make-cstring (string)
385  (let* ((len (length string)))
386    (declare (fixnum len))
387    (let* ((s (malloc (the fixnum (1+ len)))))
388      (setf (%get-byte s len) 0)
389      (multiple-value-bind (data offset) (array-data-and-offset string)
390        (%copy-ivector-to-ptr data offset s 0 len)
391        s))))
392
393
394(defun extended-string-p (thing)
395  (declare (ignore thing)))
396
397(defun simple-extended-string-p (thing)
398  (declare (ignore thing)))
399
400
401
402(defun move-string-bytes (source dest off1 off2 n)
403  (declare (optimize (speed 3)(safety 0)))
404  (declare (fixnum off1 off2 n))
405  (let* ((base-source (typep source 'simple-base-string))
406         (base-dest (typep dest 'simple-base-string)))
407    (if (and base-dest base-source)
408      (%copy-ivector-to-ivector source off1 dest off2 n))))
409
410
411(defun %str-cat (s1 s2 &rest more)
412  (declare (dynamic-extent more))
413  (require-type s1 'simple-string)
414  (require-type s2 'simple-string)
415  (let* ((len1 (length s1))
416         (len2 (length s2))
417         (len (%i+ len2 len1)))
418    (declare (optimize (speed 3)(safety 0)))
419    (dolist (s more)
420      (require-type s 'simple-string)
421      (setq len (+ len (length s))))
422    (let ((new-string (make-string len :element-type 'base-char)))
423      (move-string-bytes s1 new-string 0 0 len1)
424      (move-string-bytes s2 new-string 0 len1 len2)
425      (dolist (s more)
426        (setq len2 (%i+ len1 len2))
427        (move-string-bytes s new-string 0 len2 (setq len1 (length s))))
428      new-string)))
429
430
431(defun %substr (str start end)
432  (require-type start 'fixnum)
433  (require-type end 'fixnum)
434  (require-type str 'string)
435  (let ((len (length str)))
436    (multiple-value-bind (str strb)(array-data-and-offset str)
437      (let ((newlen (%i- end start)))
438        (when (%i> end len)(error "End ~S exceeds length ~S." end len))
439        (when (%i< start 0)(error "Negative start"))
440        (let ((new (make-string newlen :element-type (array-element-type str))))
441          (move-string-bytes str new (%i+ start strb) 0 newlen)
442          new)))))
443
444
445(defun coerce-to-uvector (object subtype simple-p)  ; simple-p ? 
446  (let ((type-code (typecode object)))
447    (cond ((eq type-code target::tag-list)
448           (%list-to-uvector subtype object))
449          ((>= type-code target::min-cl-ivector-subtag)  ; 175
450           (if (or (null subtype)(= subtype type-code))
451             (return-from coerce-to-uvector object)))
452          ((>= type-code target::min-vector-subtag)     ; 170
453           (if (= type-code target::subtag-simple-vector)
454             (if (or (null subtype)
455                     (= type-code subtype))
456               (return-from coerce-to-uvector object))
457             (if (and (null simple-p)
458                      (or (null subtype)
459                          (= subtype (typecode (array-data-and-offset object)))))
460               (return-from coerce-to-uvector object))))
461          (t (error "Can't coerce ~s to Uvector" object))) ; or just let length error
462    (if (null subtype)(setq subtype target::subtag-simple-vector))
463    (let* ((size (length object))
464           (val (%alloc-misc size subtype)))
465      (declare (fixnum size))
466      (multiple-value-bind (vect offset) (array-data-and-offset object)
467        (declare (fixnum offset))
468        (dotimes (i size val)
469          (declare (fixnum i)) 
470          (uvset val i (uvref vect (%i+ offset i))))))))
471
472
473
474
475
476
477
478
479; 3 callers
480(defun %list-to-uvector (subtype list)   ; subtype may be nil (meaning simple-vector
481  (let* ((n (length list))
482         (new (%alloc-misc n (or subtype target::subtag-simple-vector))))  ; yech
483    (dotimes (i n)
484      (declare (fixnum i))
485      (uvset new i (%car list))
486      (setq list (%cdr list)))
487    new))
488
489
490; appears to be unused
491(defun upgraded-array-element-type (type &optional env)
492  (declare (ignore env))
493  (element-subtype-type (element-type-subtype type)))
494
495(defun upgraded-complex-part-type (type &optional env)
496  (declare (ignore env))
497  (declare (ignore type))               ; Ok, ok.  So (upgraded-complex-part-type 'bogus) is 'REAL. So ?
498  'real)
499
500
501
502(progn
503  ; we are making assumptions - put in ppc-arch? - almost same as *ppc-immheader-array-types
504  (defparameter array-element-subtypes
505    #(single-float 
506      (unsigned-byte 32)
507      (signed-byte 32)
508      (unsigned-byte 8)
509      (signed-byte 8)
510      base-char
511      *unused*
512      (unsigned-byte 16)
513      (signed-byte 16)
514      double-float
515      bit))
516 
517  ; given uvector subtype - what is the corresponding element-type
518  (defun element-subtype-type (subtype)
519    (declare (fixnum subtype))
520    (if  (= subtype ppc32::subtag-simple-vector) t
521        (svref array-element-subtypes 
522               (ash (- subtype ppc32::min-cl-ivector-subtag) (- ppc32::ntagbits)))))
523  )
524
525
526
527
528
529
530;Used by transforms.
531(defun make-uvector (length subtype &key (initial-element () initp))
532  (if initp
533    (%alloc-misc length subtype initial-element)
534    (%alloc-misc length subtype)))
535
536; %make-displaced-array assumes the following
537
538(eval-when (:compile-toplevel)
539  (assert (eql target::arrayH.flags-cell target::vectorH.flags-cell))
540  (assert (eql target::arrayH.displacement-cell target::vectorH.displacement-cell))
541  (assert (eql target::arrayH.data-vector-cell target::vectorH.data-vector-cell)))
542
543
544(defun %make-displaced-array (dimensions displaced-to
545                                         &optional fill adjustable
546                                         offset explicitp)
547  (if offset 
548    (unless (and (fixnump offset) (>= (the fixnum offset) 0))
549      (setq offset (require-type offset '(and fixnum (integer 0 *)))))
550    (setq offset 0))
551  (locally (declare (fixnum offset))
552    (let* ((disp-size (array-total-size displaced-to))
553           (rank (if (listp dimensions)(length dimensions) 1))
554           (new-size (if (fixnump dimensions)
555                       dimensions
556                       (if (listp dimensions)
557                         (if (eql rank 1)
558                           (car dimensions)
559                           (if (eql rank 0) 1 ; why not 0?
560                           (apply #'* dimensions))))))
561           (vect-subtype (%vect-subtype displaced-to))
562           (target displaced-to)
563           (real-offset offset)
564           (flags 0))
565      (declare (fixnum disp-size rank flags vect-subtype real-offset))
566      (when explicitp
567        (setq flags (bitset $arh_exp_disp_bit flags)))
568      (if (not (fixnump new-size))(error "Bad array dimensions ~s." dimensions)) 
569      (locally (declare (fixnum new-size))
570        ; (when (> (+ offset new-size) disp-size) ...), but don't cons bignums
571        (when (or (> new-size disp-size)
572                  (let ((max-offset (- disp-size new-size)))
573                    (declare (fixnum max-offset))
574                    (> offset max-offset)))
575          (%err-disp $err-disp-size displaced-to))
576        (if adjustable  (setq flags (bitset $arh_adjp_bit flags)))
577        (when fill
578          (if (eq fill t)
579            (setq fill new-size)
580            (unless (and (eql rank 1)
581                         (fixnump fill)
582                         (locally (declare (fixnum fill))
583                           (and (>= fill 0) (<= fill new-size))))
584              (error "Bad fill pointer ~s" fill)))
585          (setq flags (bitset $arh_fill_bit flags))))
586      ; If displaced-to is an array or vector header and is either
587      ; adjustable or its target is a header, then we need to set the
588      ; $arh_disp_bit. If displaced-to is not adjustable, then our
589      ; target can be its target instead of itself.
590      (when (or (eql vect-subtype target::subtag-arrayH)
591                (eql vect-subtype target::subtag-vectorH))
592        (let ((dflags (%svref displaced-to target::arrayH.flags-cell)))
593          (declare (fixnum dflags))
594          (when (or (logbitp $arh_adjp_bit dflags)
595                    t
596                    (progn
597                      #+nope
598                      (setq target (%svref displaced-to target::arrayH.data-vector-cell)
599                            real-offset (+ offset (%svref displaced-to target::arrayH.displacement-cell)))
600                      (logbitp $arh_disp_bit dflags)
601                      #-nope t))
602            (setq flags (bitset $arh_disp_bit flags))))
603        (setq vect-subtype (%array-header-subtype displaced-to)))
604      ; assumes flags is low byte
605      (setq flags (dpb vect-subtype target::arrayH.flags-cell-subtag-byte flags))
606      (if (eq rank 1)
607        (%gvector target::subtag-vectorH 
608                      (if (fixnump fill) fill new-size)
609                      new-size
610                      target
611                      real-offset
612                      flags)
613        (let ((val (%alloc-misc (+ target::arrayh.dim0-cell rank) target::subtag-arrayH)))
614          (setf (%svref val target::arrayH.rank-cell) rank)
615          (setf (%svref val target::arrayH.physsize-cell) new-size)
616          (setf (%svref val target::arrayH.data-vector-cell) target)
617          (setf (%svref val target::arrayH.displacement-cell) real-offset)
618          (setf (%svref val target::arrayH.flags-cell) flags)
619          (do* ((dims dimensions (cdr dims))
620                (i 0 (1+ i)))             
621               ((null dims))
622            (declare (fixnum i)(list dims))
623            (setf (%svref val (%i+ target::arrayH.dim0-cell i)) (car dims)))
624          val)))))
625
626(defun make-array (dims &key (element-type t element-type-p)
627                        displaced-to
628                        displaced-index-offset
629                        adjustable
630                        fill-pointer
631                        (initial-element nil initial-element-p)
632                        (initial-contents nil initial-contents-p))
633  (when (and initial-element-p initial-contents-p)
634        (error "Cannot specify both ~S and ~S" :initial-element-p :initial-contents-p))
635  (make-array-1 dims element-type element-type-p
636                displaced-to
637                displaced-index-offset
638                adjustable
639                fill-pointer
640                initial-element initial-element-p
641                initial-contents initial-contents-p
642                nil))
643
644
645
646
647
648(defun vector-pop (vector)
649  (let* ((fill (fill-pointer vector)))
650    (declare (fixnum fill))
651    (if (zerop fill)
652      (error "Fill pointer of ~S is 0 ." vector)
653      (progn
654        (decf fill)
655        (%set-fill-pointer vector fill)
656        (aref vector fill)))))
657
658
659
660
661(defun elt (sequence idx)
662  (seq-dispatch
663   sequence
664   (let* ((cell (nthcdr idx sequence)))
665     (declare (list cell))
666     (if cell (car cell) (%err-disp $XACCESSNTH idx sequence)))
667   (progn
668     (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0))
669       (report-bad-arg idx 'unsigned-byte))
670     (locally 
671       (if (>= idx (length sequence))
672         (%err-disp $XACCESSNTH idx sequence)
673         (aref sequence idx))))))
674
675
676
677
678(defun set-elt (sequence idx value)
679  (seq-dispatch
680   sequence
681   (let* ((cell (nthcdr idx sequence)))
682     (if cell 
683       (locally 
684         (declare (cons cell))
685         (setf (car cell) value))
686       (%err-disp $XACCESSNTH idx sequence)))
687   (progn
688     (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0))
689       (report-bad-arg idx 'unsigned-byte))
690     (locally 
691       (declare (fixnum idx))
692       (if (>= idx (length sequence))
693         (%err-disp $XACCESSNTH idx sequence)
694         (setf (aref sequence idx) value))))))
695
696
697
698
699(%fhave 'equalp #'equal)                ; bootstrapping
700
701(defun copy-tree (tree)
702  (if (atom tree)
703    tree
704    (locally (declare (type cons tree))
705      (do* ((tail (cdr tree) (cdr tail))
706            (result (cons (copy-tree (car tree)) nil))
707            (ptr result (cdr ptr)))
708           ((atom tail)
709            (setf (cdr ptr) tail)
710            result)
711        (declare (type cons ptr result))
712        (locally 
713          (declare (type cons tail))
714          (setf (cdr ptr) (cons (copy-tree (car tail)) nil)))))))
715
716
717
718
719(defvar *periodic-task-interval* 0.3)
720(defvar *periodic-task-seconds* 0)
721(defvar *periodic-task-nanoseconds* 300000000)
722
723(defun set-periodic-task-interval (n)
724  (multiple-value-setq (*periodic-task-seconds* *periodic-task-nanoseconds*)
725    (nanoseconds n))
726  (setq *periodic-task-interval* n))
727
728(defun periodic-task-interval ()
729  *periodic-task-interval*)
730
731
732
733(defun char-downcase (c)
734  (let* ((code (char-code c)))
735    (if (and (%i>= code (char-code #\A))(%i<= code (char-code #\Z)))
736      (%code-char (%i+ code #.(- (char-code #\a)(char-code #\A))))
737    c)))
738
739
740
741(defun digit-char-p (char &optional radix)
742  (let* ((code (char-code char))
743         (r (if radix (if (and (typep radix 'fixnum)
744                               (%i>= radix 2)
745                               (%i<= radix 36))
746                        radix
747                        (%validate-radix radix)) 10))
748         (weight (if (and (<= code (char-code #\9))
749                          (>= code (char-code #\0)))
750                   (the fixnum (- code (char-code #\0)))
751                   (if (and (<= code (char-code #\Z))
752                            (>= code (char-code #\A)))
753                     (the fixnum (+ 10 (the fixnum (- code (char-code #\A)))))
754                   (if (and (<= code (char-code #\z))
755                            (>= code (char-code #\a)))
756                     (the fixnum (+ 10 (the fixnum (- code (char-code #\a))))))))))
757    (declare (fixnum code r))
758    (and weight (< (the fixnum weight) r) weight)))
759
760
761
762
763
764(defun char-upcase (c)
765  (let* ((code (char-code c)))
766    (if (and (%i>= code (char-code #\a))(%i<= code (char-code #\z)))
767      (%code-char (%i- code #.(- (char-code #\a)(char-code #\A))))
768      c)))
769
770(defun chkbounds (arr start end)
771  (flet ((are (a i)(error "Array index ~S out of bounds for ~S." a i)))
772    (let ((len (length arr)))
773      (if (and end (> end len))(are arr end))
774      (if (and start (or (< start 0)(> start len)))(are arr start))
775      (if (%i< (%i- (or end len)(or start 0)) 0)
776        (error "Start ~S exceeds end ~S." start end)))))
777
778(defun string-start-end (string start end)
779  (setq string (string string))
780  (let ((len (length (the string string))))
781    (flet ((are (a i)(error "Array index ~S out of bounds for ~S." i a)))   
782      (if (and end (> end len))(are string end))
783      (if (and start (or (< start 0)(> start len)))(are string start))
784      (setq start (or start 0) end (or end len))
785      (if (%i> start end)
786        (error "Start ~S exceeds end ~S." start end))
787      (multiple-value-bind (str off)(array-data-and-offset string)
788        (values str (%i+ off start)(%i+ off end))))))
789
790(defun get-properties (place indicator-list)
791  "Like GETF, except that Indicator-List is a list of indicators which will
792  be looked for in the property list stored in Place.  Three values are
793  returned, see manual for details."
794  (do ((plist place (cddr plist)))
795      ((null plist) (values nil nil nil))
796    (cond ((atom (cdr plist))
797           (report-bad-arg place '(satisfies plistp)))
798          ((memq (car plist) indicator-list) ;memq defined in kernel
799           (return (values (car plist) (cadr plist) plist))))))
800
801(defun string= (string1 string2 &key start1 end1 start2 end2)
802    (locally (declare (optimize (speed 3)(safety 0)))
803      (if (and (simple-string-p string1)(null start1)(null end1))
804        (setq start1 0 end1 (length string1))
805        (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
806      (if (and (simple-string-p string2)(null start2)(null end2))
807        (setq start2 0 end2 (length string2))
808        (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))   
809      (%simple-string= string1 string2 start1 start2 end1 end2)))
810
811
812(defun lfun-keyvect (lfun)
813  (let ((bits (lfun-bits lfun)))
814    (declare (fixnum bits))
815    (and (logbitp $lfbits-keys-bit bits)
816         (or (logbitp $lfbits-method-bit bits)
817             (and (not (logbitp $lfbits-gfn-bit bits))
818                  (not (logbitp $lfbits-cm-bit bits))))
819         (if (typep lfun 'interpreted-function) ; patch needs interpreted-method-function too
820           
821           (nth 4 (evalenv-fnentry (%svref lfun 1))) ; gag puke
822           (%svref lfun 1)))))
823
824
825
826(defun function-lambda-expression (fn)
827  ;(declare (values def env-p name))
828  (let* ((bits (lfun-bits (setq fn (require-type fn 'function)))))
829    (declare (fixnum bits))
830    (if (logbitp $lfbits-trampoline-bit bits)
831      (function-lambda-expression (%svref fn 1))
832      (values (uncompile-function fn)
833              (logbitp $lfbits-nonnullenv-bit bits)
834              (function-name fn)))))
835
836; env must be a lexical-environment or NIL.
837; If env contains function or variable bindings or SPECIAL declarations, return t.
838; Else return nil
839(defun %non-empty-environment-p (env)
840  (loop
841    (when (or (null env) (istruct-typep env 'definition-environment))
842      (return nil))
843    (when (or (consp (lexenv.variables env))
844              (consp (lexenv.functions env))
845              (dolist (vdecl (lexenv.vdecls env))
846                (when (eq (cadr vdecl) 'special)
847                  (return t))))
848      (return t))
849    (setq env (lexenv.parent-env env))))
850
851;(coerce object 'compiled-function)
852(defun coerce-to-compiled-function (object)
853  (setq object (coerce-to-function object))
854  (unless (typep object 'compiled-function)
855    (multiple-value-bind (def envp) (function-lambda-expression object)
856      (when (or envp (null def))
857        (%err-disp $xcoerce object 'compiled-function))
858      (setq object (compile-user-function def nil))))
859  object)
860
861
862
863(defun %set-toplevel (&optional (fun nil fun-p))
864  ;(setq fun (require-type fun '(or symbol function)))
865  (let* ((tcr (%current-tcr)))
866    (prog1 (%tcr-toplevel-function tcr)
867      (when fun-p
868        (%set-tcr-toplevel-function tcr fun)))))
869
870; Look! GC in Lisp !
871
872
873
874
875 
876
877(defun gccounts ()
878  (let* ((total (%get-gc-count))
879         (full (full-gccount))
880         (g2-count 0)
881         (g1-count 0)
882         (g0-count 0))
883    (when (egc-enabled-p)
884      (let* ((a (%active-dynamic-area)))
885        (setq g0-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older))
886        (setq g1-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older))
887        (setq g2-count (%fixnum-ref a target::area.gc-count))))
888    (values total full g2-count g1-count g0-count)))
889
890     
891
892
893
894(defglobal %pascal-functions%
895  (make-array 4 :initial-element nil))
896
897
898(defun gc-retain-pages (arg)
899  (setq *gc-event-status-bits*
900        (if arg
901          (bitset $gc-retain-pages-bit *gc-event-status-bits*)
902          (bitclr $gc-retain-pages-bit *gc-event-status-bits*)))
903  (not (null arg)))
904
905(defun gc-retaining-pages ()
906  (logbitp $gc-retain-pages-bit *gc-event-status-bits*)) 
907
908
909
910(defun egc-active-p ()
911  (and (egc-enabled-p)
912       (not (eql 0 (%get-kernel-global 'oldest-ephemeral)))))
913
914; this IS effectively a passive way of inquiring about enabled status.
915(defun egc-enabled-p ()
916  (not (eql 0 (%fixnum-ref (%active-dynamic-area) target::area.older))))
917
918(defun egc-configuration ()
919  (let* ((ta (%get-kernel-global 'tenured-area))
920         (g2 (%fixnum-ref ta target::area.younger))
921         (g1 (%fixnum-ref g2 target::area.younger))
922         (g0 (%fixnum-ref g1 target::area.younger)))
923    (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) -8)
924            (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) -8)
925            (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) -8))))
926
927
928(defun configure-egc (e0size e1size e2size)
929  (unless (egc-active-p)
930    (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-type e2size '(unsigned-byte 18)) 10)))
931          e1size (logand (lognot #xffff) (+ #xffff (ash (require-type e1size '(unsigned-byte 18)) 10)))
932          e0size (logand (lognot #xffff) (+ #xffff (ash (require-type e0size '(integer 1 #.(ash 1 18))) 10))))
933    (%configure-egc e0size e1size e2size)))
934
935
936
937(defun macptr-flags (macptr)
938  (if (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1)
939    0
940    (uvref macptr TARGET::XMACPTR.FLAGS-CELL)))
941
942
943; This doesn't really make the macptr be gcable (now has to be
944; on linked list), but we might have other reasons for setting
945; other flag bits.
946(defun set-macptr-flags (macptr value) 
947  (unless (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1)
948    (setf (%svref macptr TARGET::XMACPTR.FLAGS-CELL) value)
949    value))
950
951(defun %new-gcable-ptr (size &optional clear-p)
952  (let ((p (make-gcable-macptr $flags_DisposPtr)))
953    (%setf-macptr p (malloc size))
954    (if clear-p
955      (#_bzero p size))
956    p))
957
958;True for a-z.
959(defun lower-case-p (c)
960  (let ((code (char-code c)))
961    (and (>= code (char-code #\a))
962         (<= code (char-code #\z)))))
963
964;True for a-z A-Z
965
966
967(defun alpha-char-p (c)
968  (let* ((code (char-code c)))
969    (declare (fixnum code))
970    (or (and (>= code (char-code #\A)) (<= code (char-code #\Z)))
971        (and (>= code (char-code #\a)) (<= code (char-code #\z))))))
972
973
974
975
976; def-accessors type-tracking stuff.  Used by inspector
977(defvar *def-accessor-types* nil)
978
979(defun add-accessor-types (types names)
980  (dolist (type types)
981    (let ((cell (or (assq type *def-accessor-types*)
982                    (car (push (cons type nil) *def-accessor-types*)))))
983      (setf (cdr cell) (if (vectorp names) names (%list-to-uvector nil names))))))
984
985
986;;; Some simple explicit storage management for cons cells
987
988(def-standard-initial-binding *cons-pool* (%cons-pool nil))
989
990(defun cheap-cons (car cdr)
991  (let* ((pool *cons-pool*)
992         (cons (pool.data pool)))
993    (if cons
994      (locally (declare (type cons cons))
995        (setf (pool.data pool) (cdr cons)
996              (car cons) car
997              (cdr cons) cdr)
998        cons)
999      (cons car cdr))))
1000
1001(defun free-cons (cons)
1002  (when (consp cons)
1003    (locally (declare (type cons cons))
1004      (setf (car cons) nil
1005            (cdr cons) nil)
1006      (let* ((pool *cons-pool*)
1007             (freelist (pool.data pool)))
1008        (setf (pool.data pool) cons
1009              (cdr cons) freelist)))))
1010
1011(defun cheap-copy-list (list)
1012  (let ((l list)
1013        res)
1014    (loop
1015      (when (atom l)
1016        (return (nreconc res l)))
1017      (setq res (cheap-cons (pop l) res)))))
1018
1019(defun cheap-list (&rest args)
1020  (declare (dynamic-extent args))
1021  (cheap-copy-list args))
1022
1023;;; Works for dotted lists
1024(defun cheap-free-list (list)
1025  (let ((l list)
1026        next-l)
1027    (loop
1028      (setq next-l (cdr l))
1029      (free-cons l)
1030      (when (atom (setq l next-l))
1031        (return)))))
1032
1033(defmacro pop-and-free (place)
1034  (setq place (require-type place 'symbol))     ; all I need for now.
1035  (let ((list (gensym))
1036        (cdr (gensym)))
1037    `(let* ((,list ,place)
1038            (,cdr (cdr ,list)))
1039       (prog1
1040         (car ,list)
1041         (setf ,place ,cdr)
1042         (free-cons ,list)))))
1043
1044;;; Support for defresource & using-resource macros
1045(defun make-resource (constructor &key destructor initializer)
1046  (%cons-resource constructor destructor initializer))
1047
1048(defun allocate-resource (resource)
1049  (setq resource (require-type resource 'resource))
1050  (let ((pool (resource.pool resource))
1051        res)
1052    (without-interrupts
1053     (let ((data (pool.data pool)))
1054       (when data
1055         (setf res (car data)
1056               (pool.data pool) (cdr (the cons data)))
1057         (free-cons data))))
1058    (if res
1059      (let ((initializer (resource.initializer resource)))
1060        (when initializer
1061          (funcall initializer res)))
1062      (setq res (funcall (resource.constructor resource))))
1063    res))
1064
1065(defun free-resource (resource instance)
1066  (setq resource (require-type resource 'resource))
1067  (let ((pool (resource.pool resource))
1068        (destructor (resource.destructor resource)))
1069    (when destructor
1070      (funcall destructor instance))
1071    (without-interrupts
1072     (setf (pool.data pool)
1073           (cheap-cons instance (pool.data pool)))))
1074  resource)
1075
1076
1077
1078
1079(defpackage "OS"
1080  (:nicknames "OPERATING-SYSTEM" 
1081              #+linuxppc-target "LINUX"
1082              #+darwinppc-target "DARWIN")
1083  (:use "COMMON-LISP")
1084  (:shadow "OPEN" "CLOSE" "READ" "WRITE" "SLEEP" "LISTEN" "FTRUNCATE" "SIGNAL" "DELETE"
1085           "WARN" "ERROR" "FLOOR" "SQRT" "LOG" "EXP" "ATANH" "ASINH"
1086           "ACOSH" "TANH" "SINH" "COSH" "TAN" "SIN" "COS" "ATAN" "ASIN"
1087           "ACOS" "MIN" "MAX" "GCD" "TRUNCATE" "TIME"))
1088
1089
1090
Note: See TracBrowser for help on using the repository browser.