← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to comp/bo1.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
comp/bo1.lsp
 
1
(in-package "BCOMP")
 
2
(defvar *space* 0)
 
3
 
 
4
 
 
5
(defmacro once-only (((v val) . res) &body body)
 
6
  (cond (res `(once-only ((,v,val)) (once-only ,res ,@ body)))
 
7
        ((and (consp val) (or (eq (car val) 'function)(eq (car val) 'quote)))
 
8
         `(symbol-macrolet ((,v ,val)) ,@ body))
 
9
        (t (let ((w (gensym)))
 
10
             `(let ((,w ,val))
 
11
                (symbol-macrolet ((,v ,w))
 
12
                                 ,@ body))))))
 
13
 
 
14
(defun get-test (x &aux item lis res key fn)
 
15
    (when (<= *space*  0)
 
16
      (desetq (item lis . res) (cdr x))
 
17
      (cond (res
 
18
             (desetq (key fn . res) res)
 
19
             (cond ((or  res
 
20
                        (not (eq key :test))
 
21
                        (not (and (consp fn)
 
22
                                  (member (car fn) '(quote function)))))
 
23
                    nil)
 
24
                   (t (cadr fn))))
 
25
            (t 'eql))))
 
26
 
 
27
(setf (get 'assoc 'bo1) 'bo1-assoc)
 
28
(defun bo1-assoc (x where &aux fn ) where
 
29
  (when  (setq fn (get-test x))
 
30
    `(funcall #'(lambda (item lis)
 
31
                  (sloop for v in lis
 
32
                     when (funcall #',fn (car v) item)
 
33
                     do (return v)))
 
34
              ,@ (cdr x))))
 
35
 
 
36
(setf (get 'member 'bo1) 'bo1-member)
 
37
(defun bo1-member (x where &aux fn  ) where
 
38
  (when  (setq fn (get-test x))
 
39
    `(funcall #'(lambda (item lis)
 
40
                  (sloop for v on lis
 
41
                     when (funcall #',fn (car v) item)
 
42
                     do (return v)))
 
43
              ,@ (cdr x))))
 
44
 
 
45
(setf (get 'get 'bo1) 'bo1-get)
 
46
(defun bo1-get (x where) where
 
47
  (when (and (= *safety* 0) (< *space* 2))
 
48
    `(funcall #'(lambda (plis key &optional dflt)
 
49
                 (setq plis (symbol-plist plis))
 
50
                 (loop (cond ((null plis) (return dflt))
 
51
                             ((eq (car plis) key)(return (cadr plis)))
 
52
                             (t (setq plis (cddr plis))))))
 
53
              ,@ (cdr x))))
 
54
 
 
55
(setf (get 'mapcar 'bo1) 'bo1-mapcar)
 
56
(setf (get 'mapc 'bo1) 'bo1-mapcar)
 
57
(setf (get 'mapcan 'bo1) 'bo1-mapcar)
 
58
(defun bo1-mapcar (x where &aux fn l coll) where
 
59
  (when (and (= *safety* 0) (< *space* 2))
 
60
    (desetq (fn l) (cdr x))
 
61
    (setq coll (cdr (assoc (car x) '((mapcar . collect) (mapc . do)
 
62
                                     (mapcan . nconc)))))
 
63
    (cond ((cdddr x) nil)
 
64
          ((and (consp fn) (member (car fn) '(quote function)))
 
65
           `(funcall #'(lambda (lis)
 
66
                         (sloop for v in lis ,coll (funcall ,fn v)))
 
67
                     ,@ (cddr x)))
 
68
          (t `(funcall #'(lambda (fn lis)
 
69
                           (if (symbolp fn) (setq fn (symbol-function fn)))
 
70
                           (sloop for v in lis ,coll (funcall fn v)))
 
71
                       ,@ (cdr x))))))
 
72
 
 
73
(setf (get 'funcall 'bo1) 'bo1-funcall)
 
74
(defun bo1-funcall (x where &aux fn  tem args ll w binds) where
 
75
  (desetq (fn . args)  (cdr x))
 
76
  (cond  ((and (consp fn)
 
77
               (or (eq (car fn) 'quote)
 
78
                   (eq (car fn) 'function))
 
79
               (consp (cdr fn))
 
80
               (setq tem (cadr fn))
 
81
               (symbolp tem))
 
82
          `(,(cadr fn) ,@ args))
 
83
         (tem
 
84
          (cond ((and (consp tem) (eq (car tem) 'lambda))
 
85
                 (desetq (ll) (cdr tem))
 
86
                 (setq ll (decode-ll ll))
 
87
                 (cond ((and   (null (ll &key ll))
 
88
                                   (null (ll &rest ll))
 
89
                                   (null (ll &aux ll)))
 
90
                        (sloop for v in (ll &required ll)
 
91
                           do (desetq (w) args)
 
92
                           (setq args (cdr args))
 
93
                           (push (list v w)  binds))
 
94
                        (sloop for v in (ll &optional ll)
 
95
                           do
 
96
                           (cond (args
 
97
                                  (or (consp args)  (comp-error "bad arglist in ~a " x))
 
98
                                  (push (list (car v) (pop args)) binds))
 
99
                                 (t (push (list (car v) (cadr v)) binds)))
 
100
                           (cond ((caddr v)
 
101
                                  (push (list (caddr v)
 
102
                                              (not (null args)))
 
103
                                        binds))))
 
104
                        `(let ,(nreverse binds)
 
105
                           ,@ (cddr tem)))))))
 
106
         (t  nil)))
 
107
 
 
108
(setf (get 'typep 'b1.5) 'b1.5-typep)
 
109
(defun b1.5-typep (x where &aux (cd (third x))
 
110
                     (args (call-data-arglist cd)))
 
111
  where
 
112
  (let ((rt (result-type (nth 0 args)))
 
113
        (typ  (nth 1 args)))
 
114
    (cond ((and (consp typ)
 
115
                (eq (car typ) 'dv)
 
116
                (subtypep rt (THIRD typ)))
 
117
           (get-object t)))))
 
118
 
 
119
(defmacro dotimes ((var form &optional (val nil)) &rest body
 
120
                                                  &aux (temp (gensym)))
 
121
  `(do* ((,temp ,form) (,var 0 (1+ ,var)))
 
122
        ((>= ,var ,temp) ,val)
 
123
     ,@ (cond ((typep form 'fixnum)
 
124
               `((declare (fixnum ,temp ,var)))))
 
125
        ,@body))
 
126
 
 
127
(defmacro psetq (&optional var val &rest l &aux sets types  decls binds)
 
128
  (cond ((null var) nil)
 
129
        ((null l) `(setq ,var ,val))
 
130
        (t (loop
 
131
            (push `(,(gensym) ,val) binds)
 
132
            (push var sets)
 
133
            (push (caar binds) sets)
 
134
            (push `(type (type-of ,var) ,(caar binds)) types) 
 
135
            (or l  (return nil))
 
136
            (desetq (var val) l) (setq l (cddr l)))
 
137
           `(let ,(nreverse binds)
 
138
              (declare ,@ types)
 
139
              (setq  ,@(nreverse sets))))))
 
140
 
 
141
;;
 
142
;;- Local variables:
 
143
;;- mode:lisp
 
144
;;- version-control:t
 
145
;;- End:
 
146
 
 
147
 
 
148
 
 
149