source: branches/ia32/level-0/l0-utils.lisp @ 7430

Last change on this file since 7430 was 6916, checked in by gb, 14 years ago

s32->u32, u32->s32.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.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
18
19; l0-utils.lisp
20
21
22(in-package "CCL")
23
24(defun %proclaim-notspecial (sym)
25  (%symbol-bits sym (logandc2 (%symbol-bits sym) (ash 1 $sym_bit_special))))
26
27
28
29;;; We MAY need a scheme for finding all of the areas in a lisp library.
30(defun %map-areas (function &optional (maxcode area-dynamic) (mincode area-readonly))
31  (declare (fixnum maxcode mincode))
32  (do* ((a (%normalize-areas) (%lisp-word-ref a (ash target::area.succ (- target::fixnumshift))))
33        (code area-dynamic (%lisp-word-ref a (ash target::area.code (- target::fixnumshift))))
34        (dynamic t nil))
35       ((= code area-void))
36    (declare (fixnum code))
37    (if (and (<= code maxcode)
38             (>= code mincode))
39      (if dynamic 
40        (walk-dynamic-area a function)
41        (unless (= code area-dynamic)        ; ignore egc areas, 'cause walk-dynamic-area sees them.
42          (walk-static-area a function))))))
43
44
45;;; there'll be functions in static lib areas.
46;;; (Well, there would be if there were really static lib areas.)
47
48(defun %map-lfuns (f)
49  (let* ((filter #'(lambda (obj) (when (= (the fixnum (typecode obj))
50                                          target::subtag-function)
51                                   (funcall f (lfun-vector-lfun obj))))))
52    (declare (dynamic-extent filter))
53    (%map-areas filter area-dynamic area-managed-static)))
54
55
56(defun ensure-simple-string (s)
57  (cond ((simple-string-p s) s)
58        ((stringp s)
59         (let* ((len (length s))
60                (new (make-string len :element-type 'base-char)))
61           (declare (fixnum len)(optimize (speed 3)(safety 0)))
62           (multiple-value-bind (ss offset) (array-data-and-offset s)
63             (%copy-ivector-to-ivector ss (ash offset 2) new 0 (ash len 2)))
64           new))
65        (t (report-bad-arg s 'string))))
66
67(defun nremove (elt list)
68  (let* ((handle (cons nil list))
69         (splice handle))
70    (declare (dynamic-extent handle))
71    (loop
72      (if (eq elt (car (%cdr splice)))
73        (unless (setf (%cdr splice) (%cddr splice)) (return))
74        (unless (cdr (setq splice (%cdr splice)))
75          (return))))
76    (%cdr handle)))
77
78
79(eval-when (:compile-toplevel :execute)
80  #+ppc32-target
81  (defmacro need-use-eql-macro (key)
82    `(let* ((typecode (typecode ,key)))
83       (declare (fixnum typecode))
84       (or (= typecode ppc32::subtag-macptr)
85           (and (>= typecode ppc32::min-numeric-subtag)
86                (<= typecode ppc32::max-numeric-subtag)))))
87  #+64-bit-target
88  (defmacro need-use-eql-macro (key)
89    `(let* ((typecode (typecode ,key)))
90       (declare (fixnum typecode))
91      (cond ((= typecode target::tag-fixnum) t)
92            ((= typecode target::subtag-single-float) t)
93            ((= typecode target::subtag-bignum) t)
94            ((= typecode target::subtag-double-float) t)
95            ((= typecode target::subtag-ratio) t)
96            ((= typecode target::subtag-complex) t)
97            ((= typecode target::subtag-macptr) t))))
98
99)
100
101(defun asseql (item list)
102  (if (need-use-eql-macro item)
103    (dolist (pair list)
104      (if pair
105        (if (eql item (car pair))
106          (return pair))))
107    (assq item list)))
108
109;;; (memeql item list) <=> (member item list :test #'eql :key #'identity)
110(defun memeql (item list)
111  (if (need-use-eql-macro item)
112    (do* ((l list (%cdr l)))
113         ((endp l))
114      (when (eql (%car l) item) (return l)))
115    (memq item list))
116)
117
118
119; (member-test item list test-fn)
120;   <=>
121;     (member item list :test test-fn :key #'identity)
122(defun member-test (item list test-fn)
123  (if (or (eq test-fn 'eq)(eq test-fn  #'eq)
124          (and (or (eq test-fn 'eql)(eq test-fn  #'eql))
125               (not (need-use-eql-macro item))))
126    (do* ((l list (cdr l)))
127         ((null l))
128      (when (eq item (car l))(return l)))
129    (if (or (eq test-fn 'eql)(eq test-fn  #'eql))
130      (do* ((l list (cdr l)))
131           ((null l))
132        (when (eql item (car l))(return l)))   
133      (do* ((l list (cdr l)))
134           ((null l))
135        (when (funcall test-fn item (car l)) (return l))))))
136
137(defun s32->u32 (s32)
138  (%stack-block ((buf 4))
139    (setf (%get-signed-long buf) s32)
140    (%get-unsigned-long buf)))
141
142(defun u32->s32 (u32)
143  (%stack-block ((buf 4))
144    (setf (%get-unsigned-long buf) u32)
145    (%get-signed-long buf)))
146
147
148; end
Note: See TracBrowser for help on using the repository browser.