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

Last change on this file since 6016 was 6016, checked in by gb, 13 years ago

Bind *GENSYM-COUNTER* per-thread.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 39.8 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(def-standard-initial-binding *gensym-counter* 0)
45
46(defun %badarg (arg type)
47  (%err-disp $XWRONGTYPE arg type))
48
49(defun atom (arg)
50  "Return true if OBJECT is an ATOM, and NIL otherwise."
51  (not (consp arg)))
52
53(defun list (&rest args)
54  "Return constructs and returns a list of its arguments."
55  args)
56
57(%fhave '%temp-list #'list)
58
59(defun list* (arg &rest others)
60  "Return a list of the arguments with last cons a dotted pair"
61  (cond ((null others) arg)
62        ((null (cdr others)) (cons arg (car others)))
63        (t (do ((x others (cdr x)))
64               ((null (cddr x)) (rplacd x (cadr x))))
65           (cons arg others))))
66
67
68
69(defun funcall (fn &rest args)
70  "Call FUNCTION with the given ARGUMENTS."
71  (declare (dynamic-extent args))
72  (apply fn args))
73
74
75(defun apply (function arg &rest args)
76  "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in
77   the manner of LIST*. That is, a list is made of the values of all but the
78   last argument, appended to the value of the last argument, which must be a
79   list."
80  (declare (dynamic-extent args))
81  (cond ((null args)
82         (apply function arg))
83        ((null (cdr args))
84         (apply function arg (car args)))
85        (t (do* ((a1 args a2)
86                 (a2 (cdr args) (cdr a2)))
87                ((atom (cdr a2))
88                 (rplacd a1 (car a2))
89                 (apply function arg args))))))
90
91
92;;; This is not fast, but it gets the functionality that
93;;; Wood and possibly other code depend on.
94(defun applyv (function arg &rest other-args)
95  (declare (dynamic-extent other-args))
96  (let* ((other-args (cons arg other-args))
97         (last-arg (car (last other-args)))
98         (last-arg-length (length last-arg))
99         (butlast-args (nbutlast other-args))
100         (rest-args (make-list last-arg-length))
101         (rest-args-tail rest-args))
102    (declare (dynamic-extent other-args rest-args))
103    (dotimes (i last-arg-length)
104      (setf (car rest-args-tail) (aref last-arg i))
105      (pop rest-args-tail))
106    (apply function (nconc butlast-args rest-args))))
107
108;;; This is slow, and since %apply-lexpr isn't documented either,
109;;; nothing in the world should depend on it.  This is just being
110;;; anal retentive.  VERY anal retentive.
111
112(defun %apply-lexpr (function arg &rest args)
113  (cond ((null args) (%apply-lexpr function arg))
114        (t (apply function arg (nconc (nbutlast args)
115                                      (collect-lexpr-args (car (last args)) 0))))))
116
117
118(defun values-list (arg)
119  "Return all of the elements of LIST, in order, as values."
120  (apply #'values arg))
121
122
123
124(defun make-list (size &key initial-element)
125  "Constructs a list with size elements each set to value"
126  (unless (and (typep size 'fixnum)
127               (>= (the fixnum size) 0))
128    (report-bad-arg size '(and fixnum unsigned-byte)))
129  (locally (declare (fixnum size))
130    (do* ((result '() (cons initial-element result)))
131        ((zerop size) result)
132      (decf size))))
133
134
135; copy-list
136
137(defun copy-list (list)
138  "Return a new list which is EQUAL to LIST."
139  (if list
140    (let ((result (cons (car list) '()) ))
141      (do ((x (cdr list) (cdr x))
142           (splice result
143                   (%cdr (%rplacd splice (cons (%car x) '() ))) ))
144          ((atom x) (unless (null x)
145                      (%rplacd splice x)) result)))))
146
147(defun alt-list-length (l)
148  "Detect (and complain about) cirucular lists; allow any atom to
149terminate the list"
150  (do* ((n 0 (1+ n))
151        (fast l)
152        (slow l))
153       ((atom fast) n)
154    (declare (fixnum n))
155    (setq fast (cdr fast))
156    (if (logbitp 0 n)
157      (if (eq (setq slow (cdr slow)) fast)
158        (%err-disp $XIMPROPERLIST l)))))
159
160
161(defun last (list &optional (n 1))
162  "Return the last N conses (not the last element!) of a list."
163  (if (and (typep n 'fixnum)
164           (>= (the fixnum n) 0))
165    (locally (declare (fixnum n))
166      (do* ((checked-list list (cdr checked-list))
167            (returned-list list)
168            (index 0 (1+ index)))
169           ((atom checked-list) returned-list)
170        (declare (type index index))
171        (if (>= index n)
172          (pop returned-list))))
173    (if (and (typep n 'bignum)
174             (> n 0))
175      (require-type list 'list)
176      (report-bad-arg  n 'unsigned-byte))))
177
178
179
180
181
182(defun nthcdr (index list)
183  "Performs the cdr function n times on a list."
184  (if (and (typep index 'fixnum)
185           (>= (the fixnum index) 0))
186      (locally (declare (fixnum index))
187        (dotimes (i index list)
188          (when (null (setq list (cdr list))) (return))))
189      (progn
190        (unless (typep index 'unsigned-byte)
191          (report-bad-arg index 'unsigned-byte))
192        (do* ((n index (- n most-positive-fixnum)))
193             ((typep n 'fixnum) (nthcdr n list))
194          (unless (setq list (nthcdr most-positive-fixnum list))
195            (return))))))
196
197
198(defun nth (index list)
199  "Return the nth object in a list where the car is the zero-th element."
200  (car (nthcdr index list)))
201
202
203(defun nconc (&rest lists)
204  (declare (dynamic-extent lists))
205  "Concatenates the lists given as arguments (by changing them)"
206  (do* ((top lists (cdr top)))
207       ((null top) nil)
208    (let* ((top-of-top (car top)))
209      (cond
210       ((consp top-of-top)
211        (let* ((result top-of-top)
212               (splice result))
213          (do* ((elements (cdr top) (cdr elements)))
214                 ((endp elements))
215            (let ((ele (car elements)))
216              (typecase ele
217                (cons (rplacd (last splice) ele)
218                      (setf splice ele))
219                (null (rplacd (last splice) nil))
220                (atom (if (cdr elements)
221                        (report-bad-arg ele 'list)
222                        (rplacd (last splice) ele)))
223                (t (report-bad-arg ele 'list)))))
224          (return result)))
225       ((null top-of-top) nil)
226       (t
227        (if (cdr top)
228          (report-bad-arg top-of-top 'list)
229          (return top-of-top)))))))
230
231
232(defvar %setf-function-names% (make-hash-table :weak t :test 'eq))
233
234(defun setf-function-name (sym)
235   (or (gethash sym %setf-function-names%)
236       (setf (gethash sym %setf-function-names%) (construct-setf-function-name sym))))
237
238
239
240                     
241
242(defconstant *setf-package* (or (find-package "SETF") (make-package "SETF" :use nil :external-size 1)))
243
244(defun construct-setf-function-name (sym)
245  (let ((pkg (symbol-package sym)))
246    (setq sym (symbol-name sym))
247    (if (null pkg)
248      (gentemp sym *setf-package*)
249      (values
250       (intern
251        ;I wonder, if we didn't check, would anybody report it as a bug?
252        (if (not (%str-member #\: (setq pkg (package-name pkg))))
253          (%str-cat pkg "::" sym)
254          (%str-cat (prin1-to-string pkg) "::" (princ-to-string sym)))
255        *setf-package*)))))
256
257(defun setf-function-name-p (name)
258  (and (consp name)
259             (consp (%cdr name))
260             (null (%cddr name))
261             (symbolp (%cadr name))
262             (eq (car name) 'setf)))
263
264(defun valid-function-name-p (name)
265  (if (symbolp name)                    ; Nil is a valid function name.  I guess.
266    (values t name)
267    (if (setf-function-name-p name)
268      (values t (setf-function-name (%cadr name)))
269      ; What other kinds of function names do we care to support ?
270      (values nil nil))))
271
272;;; Why isn't this somewhere else ?
273(defun ensure-valid-function-name (name)
274  (multiple-value-bind (valid-p nm) (valid-function-name-p name)
275    (if valid-p nm (error "Invalid function name ~s." name))))
276
277
278;;; Returns index if char appears in string, else nil.
279
280(defun %str-member (char string &optional start end)
281  (let* ((base-string-p (typep string 'simple-base-string)))
282    (unless base-string-p
283      (setq string (require-type string 'simple-string)))
284    (unless (characterp char)
285      (setq char (require-type char 'character)))
286    (do* ((i (or start 0) (1+ i))
287            (n (or end (uvsize string))))
288           ((= i n))
289        (declare (fixnum i n) (optimize (speed 3) (safety 0)))
290        (if (eq (schar (the simple-base-string string) i) char)
291          (return i)))))
292
293
294
295;;; Returns index of elt in vector, or nil if it's not there.
296(defun %vector-member (elt vector)
297  (unless (typep vector 'simple-vector)
298    (report-bad-arg vector 'simple-vector))
299  (dotimes (i (the fixnum (length vector)))
300    (when (eq elt (%svref vector i)) (return i))))
301
302(defun logical-pathname-p (thing) (istruct-typep thing 'logical-pathname))
303
304(progn
305;;; It's back ...
306(defun list-nreverse (list)
307  (nreconc list nil))
308
309;;; We probably want to make this smarter so that less boxing
310;;; (and bignum/double-float consing!) takes place.
311
312(defun vector-nreverse (v)
313  (let* ((len (length v))
314         (middle (ash (the fixnum len) -1)))
315    (declare (fixnum middle len))
316    (do* ((left 0 (1+ left))
317          (right (1- len) (1- right)))
318         ((= left middle) v)
319      (declare (fixnum left right))
320      (rotatef (aref v left) (aref v right)))))
321   
322(defun nreverse (seq)
323  "Return a sequence of the same elements in reverse order; the argument
324   is destroyed."
325  (when seq
326    (seq-dispatch seq
327                  (list-nreverse seq)
328                  (vector-nreverse seq)))))
329
330(defun nreconc (x y)
331  "Return (NCONC (NREVERSE X) Y)."
332  (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
333       (2nd x 1st)              ;2nd follows first down the list.
334       (3rd y 2nd))             ;3rd follows 2nd down the list.
335      ((atom 2nd) 3rd)
336    (rplacd 2nd 3rd)))
337
338;;; The two-arg case is maybe a bit faster.  We -don't- want to
339;;; do the two-arg case repeatedly to implement the N-arg case.
340(defun append (&rest lists)
341  (declare (dynamic-extent lists))
342  "Construct a new list by concatenating the list arguments"
343  (if lists
344    (let* ((head (cons nil nil))
345           (tail head))
346      (declare (dynamic-extent head)
347               (cons head tail))
348      (do* ()
349           ((null lists) (cdr head))
350        (let* ((list (pop lists)))
351          (if (null lists)
352            (rplacd tail list)
353            (dolist (element list)
354                (setq tail (cdr (rplacd tail (cons element nil)))))))))))
355
356
357
358                     
359
360
361
362
363
364
365
366(progn
367(defun list-reverse (l)
368  (do* ((new ()))
369       ((null l) new)
370    (push (pop l) new)))
371
372; Again, it's worth putting more work into this when the dust settles.
373(defun vector-reverse (v)
374  (let* ((len (length v))
375         (new (make-array (the fixnum len) :element-type (array-element-type v))))   ; a LOT more work ...
376    (declare (fixnum len))
377    (do* ((left 0 (1+ left))
378          (right (1- len) (1- right)))
379         ((= left len) new)
380      (declare (fixnum left right))
381      (setf (uvref new left)
382            (aref v right)))))
383
384(defun reverse (seq)
385  "Return a new sequence containing the same elements but in reverse order."
386  (seq-dispatch seq (list-reverse seq) (vector-reverse seq)))
387)
388
389(defun check-sequence-bounds (seq start end)
390  (let* ((length (length seq)))
391    (declare (fixnum length))
392    (if (not end)
393      (setq end length)
394      (unless (typep end 'fixnum)
395        (report-bad-arg end 'fixnum)))
396    (unless (typep start 'fixnum)
397      (report-bad-arg start 'fixnum))
398    (locally (declare (fixnum start end))
399      (cond ((> end length)
400             (report-bad-arg end `(integer 0 (,length))))
401            ((< start 0)
402             (report-bad-arg start `(integer 0)))
403            ((< end 0)
404             (report-bad-arg end `(integer 0 (,length))))
405            ((> start end)
406             (report-bad-arg start `(integer 0 ,end)))
407            (t end)))))
408 
409
410(defun byte-length (string &optional  (start 0) end)
411  (setq end (check-sequence-bounds string start end))
412  (- end start))
413
414
415
416(defun make-cstring (string)
417  (let* ((len (length string)))
418    (declare (fixnum len))
419    (let* ((s (malloc (the fixnum (1+ len)))))
420      (setf (%get-byte s len) 0)
421      (multiple-value-bind (data offset) (array-data-and-offset string)
422        (dotimes (i len s)
423          (setf (%get-unsigned-byte s i) (%scharcode data (+ offset i))))
424        s))))
425
426
427(defun extended-string-p (thing)
428  (declare (ignore thing)))
429
430(defun simple-extended-string-p (thing)
431  (declare (ignore thing)))
432
433
434
435(defun move-string-bytes (source dest off1 off2 n)
436  (declare (fixnum off1 off2 n)
437           (simple-base-string source dest)
438           (optimize (speed 3) (safety 0)))
439  (dotimes (i n dest)
440    (setf (schar dest off2) (schar source off1))
441    (incf off1)
442    (incf off2)))
443
444
445(defun %str-cat (s1 s2 &rest more)
446  (declare (dynamic-extent more))
447  (require-type s1 'simple-string)
448  (require-type s2 'simple-string)
449  (let* ((len1 (length s1))
450         (len2 (length s2))
451         (len (%i+ len2 len1)))
452    (declare (optimize (speed 3)(safety 0)))
453    (dolist (s more)
454      (require-type s 'simple-string)
455      (setq len (+ len (length s))))
456    (let ((new-string (make-string len :element-type 'base-char)))
457      (move-string-bytes s1 new-string 0 0 len1)
458      (move-string-bytes s2 new-string 0 len1 len2)
459      (dolist (s more)
460        (setq len2 (%i+ len1 len2))
461        (move-string-bytes s new-string 0 len2 (setq len1 (length s))))
462      new-string)))
463
464
465(defun %substr (str start end)
466  (require-type start 'fixnum)
467  (require-type end 'fixnum)
468  (require-type str 'string)
469  (let ((len (length str)))
470    (multiple-value-bind (str strb)(array-data-and-offset str)
471      (let ((newlen (%i- end start)))
472        (when (%i> end len)(error "End ~S exceeds length ~S." end len))
473        (when (%i< start 0)(error "Negative start"))
474        (let ((new (make-string newlen)))
475          (do* ((i 0 (1+ i))
476                (pos (%i+ start strb) (1+ pos)))
477               ((= i newlen) new)
478            (declare (fixnum i pos))
479            (setf (schar new i) (schar str pos))))))))
480
481
482
483;;; 3 callers
484(defun %list-to-uvector (subtype list)   ; subtype may be nil (meaning simple-vector
485  (let* ((n (length list))
486         (new (%alloc-misc n (or subtype target::subtag-simple-vector))))  ; yech
487    (dotimes (i n)
488      (declare (fixnum i))
489      (uvset new i (%car list))
490      (setq list (%cdr list)))
491    new))
492
493
494; appears to be unused
495(defun upgraded-array-element-type (type &optional env)
496  "Return the element type that will actually be used to implement an array
497   with the specifier :ELEMENT-TYPE Spec."
498  (declare (ignore env))
499  (element-subtype-type (element-type-subtype type)))
500
501(defun upgraded-complex-part-type (type &optional env)
502  (declare (ignore env))
503  (declare (ignore type))               ; Ok, ok.  So (upgraded-complex-part-type 'bogus) is 'REAL. So ?
504  'real)
505
506
507#+ppc32-target
508(progn
509  (defparameter array-element-subtypes
510    #(single-float 
511      (unsigned-byte 32)
512      (signed-byte 32)
513      fixnum
514      base-char                         ;ucs4
515      (unsigned-byte 8)
516      (signed-byte 8)
517      base-char
518      (unsigned-byte 16)
519      (signed-byte 16)
520      double-float
521      bit))
522 
523  ;; given uvector subtype - what is the corresponding element-type
524  (defun element-subtype-type (subtype)
525    (declare (fixnum subtype))
526    (if  (= subtype ppc32::subtag-simple-vector) t
527        (svref array-element-subtypes 
528               (ash (- subtype ppc32::min-cl-ivector-subtag) (- ppc32::ntagbits)))))
529  )
530
531#+ppc64-target
532(progn
533
534(defparameter array-element-subtypes
535  #(bogus
536    bogus
537    bogus
538    bogus
539    (signed-byte 8)
540    (signed-byte 16)
541    (signed-byte 32)
542    (signed-byte 64)
543    (unsigned-byte 8)
544    (unsigned-byte 16)
545    (unsigned-byte 32)
546    (unsigned-byte 64)
547    bogus
548    bogus
549    single-float
550    fixnum
551    bogus
552    bogus
553    bogus
554    double-float
555    bogus
556    bogus
557    base-char
558    bogus
559    bogus
560    bogus
561    bogus
562    bogus
563    bogus
564    bit
565    bogus
566    bogus)) 
567
568 
569  ;;; given uvector subtype - what is the corresponding element-type
570  (defun element-subtype-type (subtype)
571    (declare (fixnum subtype))
572    (if  (= subtype ppc64::subtag-simple-vector)
573      t
574      (svref array-element-subtypes 
575             (ash (- subtype 128) -2))))
576  )
577
578#+x8664-target
579(progn
580
581  ;;; 1, 8, 16-bit element types
582  (defparameter *immheader-0-array-element-types*
583    #(bogus
584      bogus
585      bogus
586      bogus
587      bogus
588      bogus
589      bogus
590      bogus
591      bogus
592      bogus
593      (signed-byte 16)
594      (unsigned-byte 16)
595      base-char
596      (signed-byte 8)
597      (unsigned-byte 8)
598      bit))
599
600  ;;; 32-bit element types
601  (defparameter *immheader-1-array-element-types*
602    #(bogus
603      bogus
604      bogus
605      bogus
606      bogus
607      bogus
608      bogus
609      bogus
610      bogus
611      bogus
612      bogus
613      bogus
614      base-char
615      (signed-byte 32)
616      (unsigned-byte 32)
617      single-float))
618
619  ;;; 64-bit element types
620  (defparameter *immheader-2-array-element-types*
621    #(bogus
622      bogus
623      bogus
624      bogus
625      bogus
626      bogus
627      bogus
628      bogus
629      bogus
630      bogus
631      bogus
632      bogus
633      fixnum
634      (signed-byte 64)
635      (unsigned-byte 64)
636      double-float)) 
637     
638 
639  (defun element-subtype-type (subtype)
640    (declare (type (unsigned-byte 8) subtype))
641    (if (= subtype x8664::subtag-simple-vector)
642      t
643      (let* ((class (ash subtype (- x8664::ntagbits)))
644             (tag (logand subtype x8664::fulltagmask)))
645        (declare (type (unsigned-byte 4) class tag))
646        (cond ((= tag x8664::fulltag-immheader-0)
647               (%svref *immheader-0-array-element-types* class))
648              ((= tag x8664::fulltag-immheader-1)
649               (%svref *immheader-1-array-element-types* class))
650              ((= tag x8664::fulltag-immheader-2)
651               (%svref *immheader-2-array-element-types* class))
652              (t 'bogus)))))
653  )
654
655
656;;; %make-displaced-array assumes the following
657
658(eval-when (:compile-toplevel)
659  (assert (eql target::arrayH.flags-cell target::vectorH.flags-cell))
660  (assert (eql target::arrayH.displacement-cell target::vectorH.displacement-cell))
661  (assert (eql target::arrayH.data-vector-cell target::vectorH.data-vector-cell)))
662
663
664(defun %make-displaced-array (dimensions displaced-to
665                                         &optional fill adjustable
666                                         offset explicitp)
667  (if offset 
668    (unless (and (fixnump offset) (>= (the fixnum offset) 0))
669      (setq offset (require-type offset '(and fixnum (integer 0 *)))))
670    (setq offset 0))
671  (locally (declare (fixnum offset))
672    (let* ((disp-size (array-total-size displaced-to))
673           (rank (if (listp dimensions)(length dimensions) 1))
674           (new-size (if (fixnump dimensions)
675                       dimensions
676                       (if (listp dimensions)
677                         (if (eql rank 1)
678                           (car dimensions)
679                           (if (eql rank 0) 1 ; why not 0?
680                           (apply #'* dimensions))))))
681           (vect-subtype (typecode displaced-to))
682           (target displaced-to)
683           (real-offset offset)
684           (flags 0))
685      (declare (fixnum disp-size rank flags vect-subtype real-offset))
686      (when explicitp
687        (setq flags (bitset $arh_exp_disp_bit flags)))
688      (if (not (fixnump new-size))(error "Bad array dimensions ~s." dimensions)) 
689      (locally (declare (fixnum new-size))
690        ; (when (> (+ offset new-size) disp-size) ...), but don't cons bignums
691        (when (or (> new-size disp-size)
692                  (let ((max-offset (- disp-size new-size)))
693                    (declare (fixnum max-offset))
694                    (> offset max-offset)))
695          (%err-disp $err-disp-size displaced-to))
696        (if adjustable  (setq flags (bitset $arh_adjp_bit flags)))
697        (when fill
698          (if (eq fill t)
699            (setq fill new-size)
700            (unless (and (eql rank 1)
701                         (fixnump fill)
702                         (locally (declare (fixnum fill))
703                           (and (>= fill 0) (<= fill new-size))))
704              (error "Bad fill pointer ~s" fill)))
705          (setq flags (bitset $arh_fill_bit flags))))
706      ; If displaced-to is an array or vector header and is either
707      ; adjustable or its target is a header, then we need to set the
708      ; $arh_disp_bit. If displaced-to is not adjustable, then our
709      ; target can be its target instead of itself.
710      (when (or (eql vect-subtype target::subtag-arrayH)
711                (eql vect-subtype target::subtag-vectorH))
712        (let ((dflags (%svref displaced-to target::arrayH.flags-cell)))
713          (declare (fixnum dflags))
714          (when (or (logbitp $arh_adjp_bit dflags)
715                    t
716                    (progn
717                      #+nope
718                      (setq target (%svref displaced-to target::arrayH.data-vector-cell)
719                            real-offset (+ offset (%svref displaced-to target::arrayH.displacement-cell)))
720                      (logbitp $arh_disp_bit dflags)
721                      #-nope t))
722            (setq flags (bitset $arh_disp_bit flags))))
723        (setq vect-subtype (%array-header-subtype displaced-to)))
724      ; assumes flags is low byte
725      (setq flags (dpb vect-subtype target::arrayH.flags-cell-subtag-byte flags))
726      (if (eq rank 1)
727        (%gvector target::subtag-vectorH 
728                      (if (fixnump fill) fill new-size)
729                      new-size
730                      target
731                      real-offset
732                      flags)
733        (let ((val (%alloc-misc (+ target::arrayh.dim0-cell rank) target::subtag-arrayH)))
734          (setf (%svref val target::arrayH.rank-cell) rank)
735          (setf (%svref val target::arrayH.physsize-cell) new-size)
736          (setf (%svref val target::arrayH.data-vector-cell) target)
737          (setf (%svref val target::arrayH.displacement-cell) real-offset)
738          (setf (%svref val target::arrayH.flags-cell) flags)
739          (do* ((dims dimensions (cdr dims))
740                (i 0 (1+ i)))             
741               ((null dims))
742            (declare (fixnum i)(list dims))
743            (setf (%svref val (%i+ target::arrayH.dim0-cell i)) (car dims)))
744          val)))))
745
746(defun make-array (dims &key (element-type t element-type-p)
747                        displaced-to
748                        displaced-index-offset
749                        adjustable
750                        fill-pointer
751                        (initial-element nil initial-element-p)
752                        (initial-contents nil initial-contents-p))
753  (when (and initial-element-p initial-contents-p)
754        (error "Cannot specify both ~S and ~S" :initial-element-p :initial-contents-p))
755  (make-array-1 dims element-type element-type-p
756                displaced-to
757                displaced-index-offset
758                adjustable
759                fill-pointer
760                initial-element initial-element-p
761                initial-contents initial-contents-p
762                nil))
763
764
765
766
767
768(defun vector-pop (vector)
769  "Decrease the fill pointer by 1 and return the element pointed to by the
770  new fill pointer."
771  (let* ((fill (fill-pointer vector)))
772    (declare (fixnum fill))
773    (if (zerop fill)
774      (error "Fill pointer of ~S is 0 ." vector)
775      (progn
776        (decf fill)
777        (%set-fill-pointer vector fill)
778        (aref vector fill)))))
779
780
781
782
783(defun elt (sequence idx)
784  "Return the element of SEQUENCE specified by INDEX."
785  (seq-dispatch
786   sequence
787   (let* ((cell (nthcdr idx sequence)))
788     (if cell (car cell) (%err-disp $XACCESSNTH idx sequence)))
789   (progn
790     (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0))
791       (report-bad-arg idx 'unsigned-byte))
792     (locally 
793       (if (>= idx (length sequence))
794         (%err-disp $XACCESSNTH idx sequence)
795         (aref sequence idx))))))
796
797
798
799
800(defun set-elt (sequence idx value)
801  (seq-dispatch
802   sequence
803   (let* ((cell (nthcdr idx sequence)))
804     (if cell 
805       (locally 
806         (declare (cons cell))
807         (setf (car cell) value))
808       (%err-disp $XACCESSNTH idx sequence)))
809   (progn
810     (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0))
811       (report-bad-arg idx 'unsigned-byte))
812     (locally 
813       (declare (fixnum idx))
814       (if (>= idx (length sequence))
815         (%err-disp $XACCESSNTH idx sequence)
816         (setf (aref sequence idx) value))))))
817
818
819
820
821(%fhave 'equalp #'equal)                ; bootstrapping
822
823(defun copy-tree (tree)
824  "Recursively copy trees of conses."
825  (if (atom tree)
826    tree
827    (locally (declare (type cons tree))
828      (do* ((tail (cdr tree) (cdr tail))
829            (result (cons (copy-tree (car tree)) nil))
830            (ptr result (cdr ptr)))
831           ((atom tail)
832            (setf (cdr ptr) tail)
833            result)
834        (declare (type cons ptr result))
835        (locally 
836          (declare (type cons tail))
837          (setf (cdr ptr) (cons (copy-tree (car tail)) nil)))))))
838
839
840
841
842(defvar *periodic-task-interval* 0.3)
843(defvar *periodic-task-seconds* 0)
844(defvar *periodic-task-nanoseconds* 300000000)
845
846(defun set-periodic-task-interval (n)
847  (multiple-value-setq (*periodic-task-seconds* *periodic-task-nanoseconds*)
848    (nanoseconds n))
849  (setq *periodic-task-interval* n))
850
851(defun periodic-task-interval ()
852  *periodic-task-interval*)
853
854
855
856(defun char-downcase (c)
857  "Return CHAR converted to lower-case if that is possible."
858  (let* ((code (char-code c)))
859    (if (and (%i>= code (char-code #\A))(%i<= code (char-code #\Z)))
860      (%code-char (%i+ code #.(- (char-code #\a)(char-code #\A))))
861    c)))
862
863
864
865(defun digit-char-p (char &optional radix)
866  "If char is a digit in the specified radix, returns the fixnum for
867  which that digit stands, else returns NIL."
868  (let* ((code (char-code char))
869         (r (if radix (if (and (typep radix 'fixnum)
870                               (%i>= radix 2)
871                               (%i<= radix 36))
872                        radix
873                        (%validate-radix radix)) 10))
874         (weight (if (and (<= code (char-code #\9))
875                          (>= code (char-code #\0)))
876                   (the fixnum (- code (char-code #\0)))
877                   (if (and (<= code (char-code #\Z))
878                            (>= code (char-code #\A)))
879                     (the fixnum (+ 10 (the fixnum (- code (char-code #\A)))))
880                   (if (and (<= code (char-code #\z))
881                            (>= code (char-code #\a)))
882                     (the fixnum (+ 10 (the fixnum (- code (char-code #\a))))))))))
883    (declare (fixnum code r))
884    (and weight (< (the fixnum weight) r) weight)))
885
886
887
888
889
890(defun char-upcase (c)
891  "Return CHAR converted to upper-case if that is possible.  Don't convert
892   lowercase eszet (U+DF)."
893  (let* ((code (char-code c)))
894    (if (and (%i>= code (char-code #\a))(%i<= code (char-code #\z)))
895      (%code-char (%i- code #.(- (char-code #\a)(char-code #\A))))
896      c)))
897
898
899
900(defun string-start-end (string start end)
901  (setq string (string string))
902  (let ((len (length (the string string))))
903    (flet ((are (a i)(error "Array index ~S out of bounds for ~S." i a)))   
904      (if (and end (> end len))(are string end))
905      (if (and start (or (< start 0)(> start len)))(are string start))
906      (setq start (or start 0) end (or end len))
907      (if (%i> start end)
908        (error "Start ~S exceeds end ~S." start end))
909      (if (typep string 'simple-string)
910        (values string start end)
911        (multiple-value-bind (str off)(array-data-and-offset string)
912          (values str (%i+ off start)(%i+ off end)))))))
913
914(defun get-properties (place indicator-list)
915  "Like GETF, except that INDICATOR-LIST is a list of indicators which will
916  be looked for in the property list stored in PLACE. Three values are
917  returned, see manual for details."
918  (do ((plist place (cddr plist)))
919      ((null plist) (values nil nil nil))
920    (cond ((atom (cdr plist))
921           (report-bad-arg place '(satisfies proper-list-p)))
922          ((memq (car plist) indicator-list) ;memq defined in kernel
923           (return (values (car plist) (cadr plist) plist))))))
924
925(defun string= (string1 string2 &key start1 end1 start2 end2)
926  "Given two strings (string1 and string2), and optional integers start1,
927  start2, end1 and end2, compares characters in string1 to characters in
928  string2 (using char=)."
929    (locally (declare (optimize (speed 3)(safety 0)))
930      (if (and (simple-string-p string1)(null start1)(null end1))
931        (setq start1 0 end1 (length string1))
932        (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
933      (if (and (simple-string-p string2)(null start2)(null end2))
934        (setq start2 0 end2 (length string2))
935        (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))   
936      (%simple-string= string1 string2 start1 start2 end1 end2)))
937
938
939(defun lfun-keyvect (lfun)
940  (let ((bits (lfun-bits lfun)))
941    (declare (fixnum bits))
942    (and (logbitp $lfbits-keys-bit bits)
943         (or (logbitp $lfbits-method-bit bits)
944             (and (not (logbitp $lfbits-gfn-bit bits))
945                  (not (logbitp $lfbits-cm-bit bits))))
946         (nth-immediate lfun 1))))
947
948
949
950(defun function-lambda-expression (fn)
951  "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where
952  DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument
953  to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition
954  might have been enclosed in some non-null lexical environment, and
955  NAME is some name (for debugging only) or NIL if there is no name."
956  ;(declare (values def env-p name))
957  (let* ((bits (lfun-bits (setq fn (require-type fn 'function)))))
958    (declare (fixnum bits))
959    (if (logbitp $lfbits-trampoline-bit bits)
960      (function-lambda-expression (nth-immediate fn 1))
961      (values (uncompile-function fn)
962              (logbitp $lfbits-nonnullenv-bit bits)
963              (function-name fn)))))
964
965; env must be a lexical-environment or NIL.
966; If env contains function or variable bindings or SPECIAL declarations, return t.
967; Else return nil
968(defun %non-empty-environment-p (env)
969  (loop
970    (when (or (null env) (istruct-typep env 'definition-environment))
971      (return nil))
972    (when (or (consp (lexenv.variables env))
973              (consp (lexenv.functions env))
974              (dolist (vdecl (lexenv.vdecls env))
975                (when (eq (cadr vdecl) 'special)
976                  (return t))))
977      (return t))
978    (setq env (lexenv.parent-env env))))
979
980;(coerce object 'compiled-function)
981(defun coerce-to-compiled-function (object)
982  (setq object (coerce-to-function object))
983  (unless (typep object 'compiled-function)
984    (multiple-value-bind (def envp) (function-lambda-expression object)
985      (when (or envp (null def))
986        (%err-disp $xcoerce object 'compiled-function))
987      (setq object (compile-user-function def nil))))
988  object)
989
990
991
992(defun %set-toplevel (&optional (fun nil fun-p))
993  ;(setq fun (require-type fun '(or symbol function)))
994  (let* ((tcr (%current-tcr)))
995    (prog1 (%tcr-toplevel-function tcr)
996      (when fun-p
997        (%set-tcr-toplevel-function tcr fun)))))
998
999
1000(defun gccounts ()
1001  (let* ((total (%get-gc-count))
1002         (full (full-gccount))
1003         (g2-count 0)
1004         (g1-count 0)
1005         (g0-count 0))
1006    (when (egc-enabled-p)
1007      (let* ((a (%active-dynamic-area)))
1008        (setq g0-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older))
1009        (setq g1-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older))
1010        (setq g2-count (%fixnum-ref a target::area.gc-count))))
1011    (values total full g2-count g1-count g0-count)))
1012
1013     
1014
1015
1016
1017(defglobal %pascal-functions%
1018    #(NIL NIL NIL NIL NIL NIL NIL NIL
1019      NIL NIL NIL NIL NIL NIL NIL NIL
1020      NIL NIL NIL NIL NIL NIL NIL NIL
1021      NIL NIL NIL NIL NIL NIL NIL NIL))
1022
1023
1024(defun gc-retain-pages (arg)
1025  "Try to influence the GC to retain/recycle the pages allocated between
1026GCs if arg is true, and to release them otherwise. This is generally a
1027gtradeoff between paging and other VM considerations."
1028  (setq *gc-event-status-bits*
1029        (if arg
1030          (bitset $gc-retain-pages-bit *gc-event-status-bits*)
1031          (bitclr $gc-retain-pages-bit *gc-event-status-bits*)))
1032  (not (null arg)))
1033
1034(defun gc-retaining-pages ()
1035  "Return T if the GC tries to retain pages between full GCs and NIL if
1036it's trying to release them to improve VM paging performance."
1037  (logbitp $gc-retain-pages-bit *gc-event-status-bits*)) 
1038
1039
1040(defun gc-verbose (on-full-gc &optional (egc-too on-full-gc))
1041  "If the first (required) argument is non-NIL, configures the GC to print
1042informational messages on entry and exit to each full GC; if the first argument
1043is NIL, suppresses those messages.  The second (optional) argument controls printing of messages on entry and exit to an ephemeral GC.  Returns values as per GC-VERBOSE-P."
1044  (let* ((bits *gc-event-status-bits*))
1045    (if on-full-gc
1046      (bitsetf $gc-verbose-bit bits)
1047      (bitclrf $gc-verbose-bit bits))
1048    (if egc-too
1049      (bitsetf $egc-verbose-bit bits)
1050      (bitclrf $egc-verbose-bit bits))
1051    (setq *gc-event-status-bits* bits)
1052    (values on-full-gc egc-too)))
1053
1054
1055(defun gc-verbose-p ()
1056  "Returns two values: the first is true if the GC is configured to
1057print messages on each full GC; the second is true if the GC is configured
1058to print messages on each ephemeral GC."
1059  (let* ((bits *gc-event-status-bits*))
1060    (values (logbitp $gc-verbose-bit bits)
1061            (logbitp $egc-verbose-bit bits))))
1062
1063(defun egc-active-p ()
1064  "Return T if the EGC was active at the time of the call, NIL otherwise.
1065Since this is generally a volatile piece of information, it's not clear
1066whether this function serves a useful purpose when native threads are
1067involved."
1068  (and (egc-enabled-p)
1069       (not (eql 0 (%get-kernel-global 'oldest-ephemeral)))))
1070
1071; this IS effectively a passive way of inquiring about enabled status.
1072(defun egc-enabled-p ()
1073  "Return T if the EGC was enabled at the time of the call, NIL otherwise."
1074  (not (eql 0 (%fixnum-ref (%active-dynamic-area) target::area.older))))
1075
1076(defun egc-configuration ()
1077  "Return as multiple values the sizes in kilobytes of the thresholds
1078associated with the youngest ephemeral generation, the middle ephemeral
1079generation, and the oldest ephemeral generation."
1080  (let* ((ta (%get-kernel-global 'tenured-area))
1081         (g2 (%fixnum-ref ta target::area.younger))
1082         (g1 (%fixnum-ref g2 target::area.younger))
1083         (g0 (%fixnum-ref g1 target::area.younger)))
1084    (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) -8)
1085            (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) -8)
1086            (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) -8))))
1087
1088
1089(defun configure-egc (e0size e1size e2size)
1090  "If the EGC is currently disabled, put the indicated threshold sizes in
1091effect and returns T, otherwise, returns NIL. (The provided threshold sizes
1092are rounded up to a multiple of 64Kbytes in OpenMCL 0.14 and to a multiple
1093of 32KBytes in earlier versions.)"
1094  (unless (egc-active-p)
1095    (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-type e2size '(unsigned-byte 18)) 10)))
1096          e1size (logand (lognot #xffff) (+ #xffff (ash (require-type e1size '(unsigned-byte 18)) 10)))
1097          e0size (logand (lognot #xffff) (+ #xffff (ash (require-type e0size '(integer 1 #.(ash 1 18))) 10))))
1098    (%configure-egc e0size e1size e2size)))
1099
1100
1101
1102(defun macptr-flags (macptr)
1103  (if (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1)
1104    0
1105    (uvref macptr TARGET::XMACPTR.FLAGS-CELL)))
1106
1107
1108; This doesn't really make the macptr be gcable (now has to be
1109; on linked list), but we might have other reasons for setting
1110; other flag bits.
1111(defun set-macptr-flags (macptr value) 
1112  (unless (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1)
1113    (setf (%svref macptr TARGET::XMACPTR.FLAGS-CELL) value)
1114    value))
1115
1116(defun %new-gcable-ptr (size &optional clear-p)
1117  (let ((p (make-gcable-macptr $flags_DisposPtr)))
1118    (%setf-macptr p (malloc size))
1119    (if clear-p
1120      (#_bzero p size))
1121    p))
1122
1123;True for a-z.
1124(defun lower-case-p (c)
1125  "The argument must be a character object; LOWER-CASE-P returns T if the
1126   argument is a lower-case character, NIL otherwise."
1127  (let ((code (char-code c)))
1128    (and (>= code (char-code #\a))
1129         (<= code (char-code #\z)))))
1130
1131;True for a-z A-Z
1132
1133
1134(defun alpha-char-p (c)
1135  "The argument must be a character object. ALPHA-CHAR-P returns T if the
1136   argument is an alphabetic character, A-Z or a-z; otherwise NIL."
1137  (let* ((code (char-code c)))
1138    (declare (fixnum code))
1139    (or (and (>= code (char-code #\A)) (<= code (char-code #\Z)))
1140        (and (>= code (char-code #\a)) (<= code (char-code #\z))))))
1141
1142
1143
1144
1145; def-accessors type-tracking stuff.  Used by inspector
1146(defvar *def-accessor-types* nil)
1147
1148(defun add-accessor-types (types names)
1149  (dolist (type types)
1150    (let ((cell (or (assq type *def-accessor-types*)
1151                    (car (push (cons type nil) *def-accessor-types*)))))
1152      (setf (cdr cell) (if (vectorp names) names (%list-to-uvector nil names))))))
1153
1154
1155;;; Some simple explicit storage management for cons cells
1156
1157(def-standard-initial-binding *cons-pool* (%cons-pool nil))
1158
1159(defun cheap-cons (car cdr)
1160  (let* ((pool *cons-pool*)
1161         (cons (pool.data pool)))
1162    (if cons
1163      (locally (declare (type cons cons))
1164        (setf (pool.data pool) (cdr cons)
1165              (car cons) car
1166              (cdr cons) cdr)
1167        cons)
1168      (cons car cdr))))
1169
1170(defun free-cons (cons)
1171  (when (consp cons)
1172    (locally (declare (type cons cons))
1173      (setf (car cons) nil
1174            (cdr cons) nil)
1175      (let* ((pool *cons-pool*)
1176             (freelist (pool.data pool)))
1177        (setf (pool.data pool) cons
1178              (cdr cons) freelist)))))
1179
1180(defun cheap-copy-list (list)
1181  (let ((l list)
1182        res)
1183    (loop
1184      (when (atom l)
1185        (return (nreconc res l)))
1186      (setq res (cheap-cons (pop l) res)))))
1187
1188(defun cheap-list (&rest args)
1189  (declare (dynamic-extent args))
1190  (cheap-copy-list args))
1191
1192;;; Works for dotted lists
1193(defun cheap-free-list (list)
1194  (let ((l list)
1195        next-l)
1196    (loop
1197      (setq next-l (cdr l))
1198      (free-cons l)
1199      (when (atom (setq l next-l))
1200        (return)))))
1201
1202(defmacro pop-and-free (place)
1203  (setq place (require-type place 'symbol))     ; all I need for now.
1204  (let ((list (gensym))
1205        (cdr (gensym)))
1206    `(let* ((,list ,place)
1207            (,cdr (cdr ,list)))
1208       (prog1
1209         (car ,list)
1210         (setf ,place ,cdr)
1211         (free-cons ,list)))))
1212
1213;;; Support for defresource & using-resource macros
1214(defun make-resource (constructor &key destructor initializer)
1215  (%cons-resource constructor destructor initializer))
1216
1217(defun allocate-resource (resource)
1218  (setq resource (require-type resource 'resource))
1219  (with-lock-grabbed ((resource.lock resource))
1220    (let ((pool (resource.pool resource))
1221          res)
1222      (let ((data (pool.data pool)))
1223        (when data
1224          (setf res (car data)
1225                (pool.data pool) (cdr (the cons data)))
1226          (free-cons data)))
1227      (if res
1228        (let ((initializer (resource.initializer resource)))
1229          (when initializer
1230            (funcall initializer res)))
1231        (setq res (funcall (resource.constructor resource))))
1232      res)))
1233
1234(defun free-resource (resource instance)
1235  (setq resource (require-type resource 'resource))
1236  (with-lock-grabbed ((resource.lock resource))
1237    (let ((pool (resource.pool resource))
1238          (destructor (resource.destructor resource)))
1239      (when destructor
1240        (funcall destructor instance))
1241      (setf (pool.data pool)
1242            (cheap-cons instance (pool.data pool)))))
1243  resource)
1244
1245
1246
1247
1248(defpackage #.(ftd-interface-package-name
1249               (backend-target-foreign-type-data *target-backend*))
1250  (:nicknames "OS")
1251  (:use "COMMON-LISP"))
1252
1253
1254
Note: See TracBrowser for help on using the repository browser.