← Back to branch summary

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

« back to all changes in this revision

Viewing changes to cmpnew/gcl_cmpfun.lsp

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

Show diffs side-by-side

added added

removed removed

Lines of Context:
cmpnew/gcl_cmpfun.lsp
 
1
;; CMPFUN  Library functions.
 
2
;;;
 
3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
4
 
 
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
 
6
;;
 
7
;; GCL is free software; you can redistribute it and/or modify it under
 
8
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
9
;; the Free Software Foundation; either version 2, or (at your option)
 
10
;; any later version.
 
11
;; 
 
12
;; GCL is distributed in the hope that it will be useful, but WITHOUT
 
13
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
14
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
15
;; License for more details.
 
16
;; 
 
17
;; You should have received a copy of the GNU Library General Public License 
 
18
;; along with GCL; see the file COPYING.  If not, write to the Free Software
 
19
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
 
 
21
 
 
22
(in-package 'compiler)
 
23
 
 
24
(si:putprop 'princ 'c1princ 'c1)
 
25
(si:putprop 'princ 'c2princ 'c2)
 
26
(si:putprop 'terpri 'c1terpri 'c1)
 
27
 
 
28
(si:putprop 'apply 'c1apply 'c1)
 
29
(si:putprop 'apply 'c2apply 'c2)
 
30
(si:putprop 'apply-optimize 'c2apply-optimize 'c2)
 
31
(si:putprop 'funcall 'c1funcall 'c1)
 
32
 
 
33
(si:putprop 'rplaca 'c1rplaca 'c1)
 
34
(si:putprop 'rplaca 'c2rplaca 'c2)
 
35
(si:putprop 'rplacd 'c1rplacd 'c1)
 
36
(si:putprop 'rplacd 'c2rplacd 'c2)
 
37
 
 
38
(si:putprop 'si::memq 'c1memq 'c1)
 
39
(si:putprop 'member 'c1member 'c1)
 
40
(si:putprop 'member!2 'c2member!2 'c2)
 
41
(si:putprop 'assoc 'c1assoc 'c1)
 
42
(si:putprop 'assoc!2 'c2assoc!2 'c2)
 
43
(si:putprop 'get 'c1get 'c1)
 
44
(si:putprop 'get 'c2get 'c2)
 
45
 
 
46
(si:putprop 'nth '(c1nth-condition . c1nth) 'c1conditional)
 
47
(si:putprop 'nthcdr '(c1nthcdr-condition . c1nthcdr) 'c1conditional)
 
48
(si:putprop 'si:rplaca-nthcdr 'c1rplaca-nthcdr 'c1)
 
49
(si:putprop 'si:list-nth 'c1list-nth 'c1)
 
50
(si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2)
 
51
 
 
52
(defvar *princ-string-limit* 80)
 
53
 
 
54
(defun c1princ (args &aux stream (info (make-info)))
 
55
  (when (endp args) (too-few-args 'princ 1 0))
 
56
  (unless (or (endp (cdr args)) (endp (cddr args)))
 
57
          (too-many-args 'princ 2 (length args)))
 
58
  (setq stream (if (endp (cdr args))
 
59
                   (c1nil)
 
60
                   (c1expr* (cadr args) info)))
 
61
  (if (and (or (and (stringp (car args))
 
62
                    (<= (length (car args)) *princ-string-limit*))
 
63
               (characterp (car args)))
 
64
           (or (endp (cdr args))
 
65
               (and (eq (car stream) 'var)
 
66
                    (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL)))))
 
67
      (list 'princ info (car args)
 
68
            (if (endp (cdr args)) nil (var-loc (caaddr stream)))
 
69
            stream)
 
70
      (list 'call-global info 'princ
 
71
            (list (c1expr* (car args) info) stream))))
 
72
 
 
73
(defun c2princ (string vv-index stream)
 
74
  (cond ((eq *value-to-go* 'trash)
 
75
         (cond ((characterp string)
 
76
                (wt-nl "princ_char(" (char-code string))
 
77
                (if (null vv-index) (wt ",Cnil") (wt ",VV[" vv-index "]"))
 
78
                (wt ");"))
 
79
               ((= (length string) 1)
 
80
                (wt-nl "princ_char(" (char-code (aref string 0)))
 
81
                (if (null vv-index) (wt ",Cnil") (wt ",VV[" vv-index "]"))
 
82
                (wt ");"))
 
83
               (t
 
84
                (wt-nl "princ_str(\"")
 
85
                (dotimes** (n (length string))
 
86
                  (let ((char (schar string n)))
 
87
                       (cond ((char= char #\\) (wt "\\\\"))
 
88
                             ((char= char #\") (wt "\\\""))
 
89
                             ((char= char #\Newline) (wt "\\n"))
 
90
                             (t (wt char)))))
 
91
                (wt "\",")
 
92
                (if (null vv-index) (wt "Cnil") (wt "VV[" vv-index "]"))
 
93
                (wt ");")))
 
94
         (unwind-exit nil))
 
95
        ((eql string #\Newline) (c2call-global 'terpri (list stream) nil t))
 
96
        (t (c2call-global
 
97
            'princ
 
98
            (list (list 'LOCATION
 
99
                        (make-info :type
 
100
                          (if (characterp string) 'character 'string))
 
101
                        (list 'VV (add-object string)))
 
102
                  stream) nil t))))
 
103
 
 
104
(defun c1terpri (args &aux stream (info (make-info)))
 
105
  (unless (or (endp args) (endp (cdr args)))
 
106
          (too-many-args 'terpri 1 (length args)))
 
107
  (setq stream (if (endp args)
 
108
                   (c1nil)
 
109
                   (c1expr* (car args) info)))
 
110
  (if (or (endp args)
 
111
          (and (eq (car stream) 'var)
 
112
               (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL))))
 
113
      (list 'princ info #\Newline
 
114
            (if (endp args) nil (var-loc (caaddr stream)))
 
115
            stream)
 
116
      (list 'call-global info 'terpri (list stream))))
 
117
 
 
118
(defun c1apply (args &aux info)
 
119
  (when (or (endp args) (endp (cdr args)))
 
120
        (too-few-args 'apply 2 (length args)))
 
121
  (let ((funob (c1funob (car args))))
 
122
       (setq info (copy-info (cadr funob)))
 
123
       (setq args (c1args (cdr args) info))
 
124
       (cond ((eq (car funob) 'call-lambda)
 
125
              (let* ((lambda-expr (caddr funob))
 
126
                     (lambda-list (caddr lambda-expr)))
 
127
                    (declare (object lambda-expr lambda-list))
 
128
                    (if (and (null (cadr lambda-list))          ; No optional
 
129
                             (null (cadddr lambda-list)))       ; No keyword
 
130
                        (c1apply-optimize info
 
131
                                          (car lambda-list)
 
132
                                          (caddr lambda-list)
 
133
                                          (car (cddddr lambda-expr))
 
134
                                          args)
 
135
                       (list 'apply info funob args))))
 
136
             (t (list 'apply info funob args))))
 
137
  )
 
138
 
 
139
(defun c2apply (funob args &aux (*vs* *vs*) loc)
 
140
  (setq loc (save-funob funob))
 
141
  (let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar))))
 
142
       (do ((l args (cdr l)))
 
143
           ((endp (cdr l))
 
144
            (wt-nl "{object " last-arg ";")
 
145
            (let ((*value-to-go* last-arg)) (c2expr* (car l))))
 
146
           (declare (object l))
 
147
           (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car l))))
 
148
       (wt-nl " vs_top=base+" *vs* ";")
 
149
       (base-used)
 
150
       (cond (*safe-compile*
 
151
              (wt-nl " while(!endp(" last-arg "))")
 
152
              (wt-nl " {vs_push(car(" last-arg "));")
 
153
              (wt last-arg "=cdr(" last-arg ");}"))
 
154
             (t
 
155
              (wt-nl " while(" last-arg "!=Cnil)")
 
156
              (wt-nl " {vs_push((" last-arg ")->c.c_car);")
 
157
              (wt last-arg "=(" last-arg ")->c.c_cdr;}")))
 
158
       (wt-nl "vs_base=base+" base ";}")
 
159
       (base-used))
 
160
  (c2funcall funob 'args-pushed loc)
 
161
  )
 
162
 
 
163
(defun c1apply-optimize (info requireds rest body args
 
164
                              &aux (vl nil) (fl nil))
 
165
  (do ()
 
166
      ((or (endp (cdr args)) (endp requireds)))
 
167
      (push (pop requireds) vl)
 
168
      (push (pop args) fl))
 
169
 
 
170
  (cond ((cdr args)     ;;; REQUIREDS is NIL.
 
171
         (cmpck (null rest)
 
172
                "APPLY passes too many arguments to LAMBDA expression.")
 
173
         (push rest vl)
 
174
         (push (list 'call-global info 'list* args) fl)
 
175
         (list 'let info (reverse vl) (reverse fl) body))
 
176
        (requireds      ;;; ARGS is singleton.
 
177
         (let ((temp (make-var :kind 'LEXICAL :ref t)))
 
178
              (push temp vl)
 
179
              (push (car args) fl)
 
180
              (list 'let info (reverse vl) (reverse fl)
 
181
                    (list 'apply-optimize
 
182
                          (cadr body) temp requireds rest body))))
 
183
        (rest (push rest vl)
 
184
              (push (car args) fl)
 
185
              (list 'let info (reverse vl) (reverse fl) body))
 
186
        (t
 
187
         (let ((temp (make-var :kind 'LEXICAL :ref t)))
 
188
              (push temp vl)
 
189
              (push (car args) fl)
 
190
              (list 'let info (reverse vl) (reverse fl)
 
191
                    (list 'apply-optimize
 
192
                          (cadr body) temp requireds rest body))))
 
193
        )
 
194
  )
 
195
 
 
196
(defun c2apply-optimize (temp requireds rest body
 
197
                              &aux (*unwind-exit* *unwind-exit*) (*vs* *vs*)
 
198
                                   (*clink* *clink*) (*ccb-vs* *ccb-vs*))
 
199
  (when (or *safe-compile* *compiler-check-args*)
 
200
        (wt-nl (if rest "ck_larg_at_least" "ck_larg_exactly")
 
201
                "(" (length requireds) ",")
 
202
        (wt-var temp nil)
 
203
        (wt ");"))
 
204
 
 
205
  (dolist** (v requireds) (setf (var-ref v) (vs-push)))
 
206
  (when rest (setf (var-ref rest) (vs-push)))
 
207
 
 
208
  (do ((n 0 (1+ n))
 
209
       (vl requireds (cdr vl)))
 
210
      ((endp vl)
 
211
       (when rest
 
212
             (wt-nl) (wt-vs (var-ref rest)) (wt "= ")
 
213
             (dotimes** (i n) (wt "("))
 
214
             (wt-var temp nil)
 
215
             (dotimes** (i n) (wt-nl ")->c.c_cdr"))
 
216
             (wt ";")))
 
217
      (declare (fixnum n) (object vl))
 
218
      (wt-nl) (wt-vs (var-ref (car vl))) (wt "=(")
 
219
      (dotimes** (i n) (wt "("))
 
220
      (wt-var temp nil)
 
221
      (dotimes** (i n) (wt-nl ")->c.c_cdr"))
 
222
      (wt ")->c.c_car;"))
 
223
 
 
224
  (dolist** (var requireds) (c2bind var))
 
225
  (when rest (c2bind rest))
 
226
 
 
227
  (c2expr body)
 
228
  )
 
229
 
 
230
(defun c1funcall (args &aux funob (info (make-info)))
 
231
  (when (endp args) (too-few-args 'funcall 1 0))
 
232
  (setq funob (c1funob (car args)))
 
233
  (add-info info (cadr funob))
 
234
  (list 'funcall info funob (c1args (cdr args) info))
 
235
  )
 
236
 
 
237
 
 
238
(defun c1rplaca (args &aux (info (make-info)))
 
239
  (when (or (endp args) (endp (cdr args)))
 
240
        (too-few-args 'rplaca 2 (length args)))
 
241
  (unless (endp (cddr args))
 
242
          (too-many-args 'rplaca 2 (length args)))
 
243
  (setq args (c1args args info))
 
244
  (list 'rplaca info args))
 
245
 
 
246
(defun c2rplaca (args &aux (*vs* *vs*) (*inline-blocks* 0))
 
247
  (setq args (inline-args args '(t t)))
 
248
  (safe-compile
 
249
   (wt-nl "if(type_of(" (car args) ")!=t_cons)"
 
250
          "FEwrong_type_argument(Scons," (car args) ");"))
 
251
  (wt-nl "(" (car args) ")->c.c_car = " (cadr args) ";")
 
252
  (unwind-exit (car args))
 
253
  (close-inline-blocks)
 
254
  )
 
255
 
 
256
(defun c1rplacd (args &aux (info (make-info)))
 
257
  (when (or (endp args) (endp (cdr args)))
 
258
        (too-few-args 'rplacd 2 (length args)))
 
259
  (when (not (endp (cddr args)))
 
260
        (too-many-args 'rplacd 2 (length args)))
 
261
  (setq args (c1args args info))
 
262
  (list 'rplacd info args))
 
263
 
 
264
(defun c2rplacd (args &aux (*vs* *vs*) (*inline-blocks* 0))
 
265
  (setq args (inline-args args '(t t)))
 
266
  (safe-compile
 
267
   (wt-nl "if(type_of(" (car args) ")!=t_cons)"
 
268
          "FEwrong_type_argument(Scons," (car args) ");"))
 
269
  (wt-nl "(" (car args) ")->c.c_cdr = " (cadr args) ";")
 
270
  (unwind-exit (car args))
 
271
  (close-inline-blocks)
 
272
  )
 
273
 
 
274
(defun c1memq (args &aux (info (make-info)))
 
275
  (when (or (endp args) (endp (cdr args)))
 
276
        (too-few-args 'si::memq 2 (length args)))
 
277
  (unless (endp (cddr args))
 
278
          (too-many-args 'si::memq 2 (length args)))
 
279
  (list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info)))
 
280
        
 
281
(defun c1member (args &aux (info (make-info)))
 
282
  (when (or (endp args) (endp (cdr args)))
 
283
        (too-few-args 'member 2 (length args)))
 
284
  (cond ((endp (cddr args))
 
285
         (list 'member!2 info 'eql (c1args args info)))
 
286
        ((and (eq (caddr args) :test)
 
287
              (eql (length args) 4)     
 
288
       (member  (cadddr args) '('eq #'eq 'equal #'equal
 
289
                                'equalp #'equalp 'eql #'eql)
 
290
                :test 'equal))
 
291
         (list 'member!2 info (cadr (cadddr args))
 
292
               (c1args (list (car args) (cadr args)) info)))
 
293
        (t
 
294
         (list 'call-global info 'member (c1args args info)))))
 
295
 
 
296
(defun c2member!2 (fun args
 
297
                       &aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar)))
 
298
  (setq args (inline-args args '(t t)))
 
299
  (wt-nl "{register object x= " (car args) ",V" l "= " (cadr args) ";")
 
300
  (if *safe-compile*
 
301
      (wt-nl "while(!endp(V" l "))")
 
302
      (wt-nl "while(V" l "!=Cnil)"))
 
303
  (if (eq fun 'eq)
 
304
      (wt-nl "if(x==(V" l "->c.c_car)){")
 
305
      (wt-nl "if(" (string-downcase (symbol-name fun))
 
306
                "(x,V" l "->c.c_car)){"))
 
307
  (if (and (consp *value-to-go*)
 
308
           (or (eq (car *value-to-go*) 'JUMP-TRUE)
 
309
               (eq (car *value-to-go*) 'JUMP-FALSE)))
 
310
      (unwind-exit t 'JUMP)
 
311
      (unwind-exit (list 'CVAR l) 'JUMP))
 
312
  (wt-nl "}else V" l "=V" l "->c.c_cdr;")
 
313
  (unwind-exit nil)
 
314
  (wt "}")
 
315
  (close-inline-blocks)
 
316
  )
 
317
 
 
318
(defun c1assoc (args &aux (info (make-info)))
 
319
  (when (or (endp args) (endp (cdr args)))
 
320
        (too-few-args 'assoc 2 (length args)))
 
321
  (cond ((endp (cddr args))
 
322
         (list 'assoc!2 info 'eql (c1args args info)))
 
323
        ((and (eq (caddr args) ':test)
 
324
              (eql (length args) 4)     
 
325
       (member  (cadddr args) '('eq #'eq 'equal #'equal
 
326
                                'equalp #'equalp 'eql #'eql)
 
327
                :test 'equal))
 
328
         (list 'assoc!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info)))
 
329
        (t
 
330
         (list 'call-global info 'assoc (c1args args info)))))
 
331
 
 
332
(defun c2assoc!2 (fun args
 
333
                      &aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar))name)
 
334
  (setq args (inline-args args '(t t)))
 
335
  (setq name (symbol-name fun))
 
336
  (or (eq fun 'eq) (setq name (string-downcase name)))
 
337
  (wt-nl "{register object x= " (car args) ",V" al "= " (cadr args) ";")
 
338
  (cond (*safe-compile*
 
339
         (wt-nl "while(!endp(V" al "))")
 
340
             (wt-nl "if(type_of(V"al"->c.c_car)==t_cons &&"
 
341
                    name "(x,V" al "->c.c_car->c.c_car)){"))
 
342
        (t
 
343
         (wt-nl "while(V" al "!=Cnil)")
 
344
             (wt-nl "if(" name "(x,V" al "->c.c_car->c.c_car) &&"
 
345
                        "V"al"->c.c_car != Cnil){"))) 
 
346
  (if (and (consp *value-to-go*)
 
347
           (or (eq (car *value-to-go*) 'jump-true)
 
348
               (eq (car *value-to-go*) 'jump-false)))
 
349
      (unwind-exit t 'jump)
 
350
      (unwind-exit (list 'CAR al) 'jump))
 
351
  (wt-nl "}else V" al "=V" al "->c.c_cdr;")
 
352
  (unwind-exit nil)
 
353
  (wt "}")
 
354
  (close-inline-blocks)
 
355
  )
 
356
 
 
357
 
 
358
 
 
359
 
 
360
(defun boole3 (a b c)  (boole a b c))
 
361
(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional)
 
362
 
 
363
(defun c1boole-condition (args)
 
364
   (and (not (endp (cddr args)))
 
365
        (endp (cdddr args))
 
366
        (inline-boole3-string (car args))))
 
367
 
 
368
(defun c1boole3 (args)
 
369
  (c1expr (cons 'boole3 args)))
 
370
 
 
371
(defun inline-boole3 (&rest args)
 
372
  (let ((boole-op-arg (second (car args))))
 
373
    (or (eq (car boole-op-arg) 'fixnum-value) (error "must be constant"))
 
374
    (let ((string (inline-boole3-string  (third boole-op-arg))))
 
375
      (or string (error "should not get here boole opt"))
 
376
      (wt-inline-loc string (cdr args)))))
 
377
 
 
378
(defun inline-boole3-string (op-code)
 
379
  (and (constantp op-code) (setq op-code (eval op-code)))
 
380
  (case op-code
 
381
        (#. boole-andc1 "((~(#0))&(#1))")
 
382
        (#. boole-andc2 "(((#0))&(~(#1)))")
 
383
        (#. boole-nor   "(~((#0)|(#1)))")
 
384
        (#. boole-orc1  "(~(#0)) | (#1)))")
 
385
        (#. boole-orc2  "((#0) | (~(#1)))")
 
386
        (#. boole-nand "(~((#0) & (#1)))")
 
387
        (#. boole-eqv   "(~((#0) ^ (#1)))")
 
388
        (#. boole-and "((#0) & (#1))")
 
389
        (#. boole-xor "((#0) ^ (#1))")
 
390
        (#. boole-ior "((#0) | (#1))")))
 
391
 
 
392
(si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional)
 
393
 
 
394
(defun c1ash-condition (args)
 
395
  (let ((shamt (second args)))
 
396
    (or (typep shamt '(integer -31 31))
 
397
        (and (consp shamt)
 
398
             (eq (car  shamt) 'the)
 
399
             (let ((type (cadr  shamt)))
 
400
                (subtypep type '(integer -31 31)))))))
 
401
 
 
402
(defun c1ash (args)
 
403
  (let  ((shamt (second args))fun)
 
404
    (cond ((constantp shamt) (setq shamt (eval shamt))
 
405
           (or (si:fixnump shamt) (error "integer shift only"))
 
406
           (cond ((< shamt 0) (setq fun 'shift>> ))
 
407
                 ((>= shamt 0) (setq fun 'shift<<))))
 
408
          (t (let ((type (second shamt)))
 
409
               ;;it had to be a (the type..)
 
410
               (cond ((subtypep type '(integer 0 31))
 
411
                      (setq fun 'shift<< ))
 
412
                     ((subtypep type '(integer -31 0))
 
413
                      (setq fun 'shift>> ))
 
414
                     (t (error "should not get here")))
 
415
               )))
 
416
    (c1expr (cons fun args))))
 
417
(defun shift>> (a b) (ash a  b))
 
418
(defun shift<< (a b) (ash a  b))
 
419
(si:putprop 'ash '(c1ash-condition . c1ash)  'c1conditional)
 
420
(si:putprop 'shift>> "Lash" 'lfun)
 
421
(si:putprop 'shift<< "Lash" 'lfun)
 
422
 
 
423
(si::putprop 'ldb 'co1ldb 'co1)             
 
424
 
 
425
(defun co1ldb (f args &aux tem (len (integer-length most-positive-fixnum))) f
 
426
  (let ((specs
 
427
         (cond ((and (consp (setq tem (first args)))
 
428
                     (eq 'byte (car tem))
 
429
                     (cons (second tem) (third tem)))))))
 
430
    (cond ((and (integerp (cdr specs))
 
431
                (integerp (car specs))
 
432
                (< (+ (car specs)(cdr specs))
 
433
                   len)
 
434
                (subtypep (result-type (second args)) 'fixnum))
 
435
           (c1expr `(the fixnum (si::ldb1 ,(car specs) ,(cdr specs) ,(second args))))))))
 
436
 
 
437
          
 
438
(si:putprop 'length 'c1length 'c1)
 
439
 
 
440
(defun c1length (args &aux (info (make-info)))
 
441
  (setf (info-type info) 'fixnum)
 
442
  (cond ((and (consp (car args))
 
443
              (eq (caar args) 'symbol-name)
 
444
              (let ((args1 (cdr (car args))))
 
445
                (and args1 (not (cddr args1))
 
446
                     (list 'call-global info 'symbol-length
 
447
                           (c1args args1 info))))))
 
448
        (t  (setq args (c1args args info))
 
449
            (list 'call-global info 'length args ))))
 
450
 
 
451
 
 
452
(defun c1get (args &aux (info (make-info)))
 
453
 
 
454
  (when (or (endp args) (endp (cdr args)))
 
455
        (too-few-args 'get 2 (length args)))
 
456
  (when (and (not (endp (cddr args))) (not (endp (cdddr args))))
 
457
        (too-many-args 'get 3 (length args)))
 
458
  (list 'get info (c1args args info)))
 
459
 
 
460
(defun c2get (args)
 
461
  (if *safe-compile*
 
462
      (c2call-global 'get args nil t)
 
463
      (let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar)))
 
464
           (setq args (inline-args args (if (cddr args) '(t t t) '(t t))))
 
465
           (wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;")
 
466
           (wt-nl " object ind= " (cadr args) ";")
 
467
           (wt-nl "while(V" pl "!=Cnil){")
 
468
           (wt-nl "if(V" pl "->c.c_car==ind){")
 
469
           (unwind-exit (list 'CADR pl) 'jump)
 
470
           (wt-nl "}else V" pl "=V" pl "->c.c_cdr->c.c_cdr;}")
 
471
           (unwind-exit (if (cddr args) (caddr args) nil))
 
472
           (wt "}")
 
473
           (close-inline-blocks)))
 
474
  )
 
475
 
 
476
(defun co1eql (f args) f
 
477
  (or (and (cdr args) (not *safe-compile*))
 
478
      (return-from co1eql nil))
 
479
  (cond ((replace-constant args)
 
480
         (cond ((characterp (second args))
 
481
                (setq args (reverse args))))
 
482
         (cond ((characterp (car args))
 
483
                (let ((c (gensym)))
 
484
                  (c1expr
 
485
                   `(let ((,c ,(second args)))
 
486
                      (declare (type ,(result-type (second args))
 
487
                                     ,c))
 
488
                      (and (typep ,c 'character)
 
489
                           (= (char-code ,(car args))
 
490
                              (the fixnum
 
491
                                   (char-code
 
492
                                    (the character
 
493
                                         ,c)))
 
494
                              ))))))))))
 
495
 
 
496
 
 
497
         
 
498
(si::putprop 'eql 'co1eql 'co1)             
 
499
 
 
500
(defvar *frozen-defstructs* nil)
 
501
 
 
502
;; Return the most particular type we can EASILY obtain
 
503
;; from x.  
 
504
(defun result-type (x)
 
505
  (cond ((symbolp x)
 
506
         (let ((tem (c1expr x)))
 
507
           (info-type (second tem))))
 
508
        ((constantp x)
 
509
         (type-filter (type-of x)))
 
510
        ((and (consp x) (eq (car x) 'the))
 
511
         (type-filter (second x)))
 
512
        (t t)))
 
513
 
 
514
 
 
515
 
 
516
(defvar *type-alist*
 
517
  '((fixnum . si::fixnump)
 
518
    (float . floatp)
 
519
    (short-float . short-float-p)
 
520
    (long-float . long-float-p)
 
521
    (integer . integerp)
 
522
    (character . characterp)
 
523
    (symbol . symbolp)
 
524
    (cons . consp)
 
525
    (null . null)
 
526
    (array . arrayp)
 
527
    (vector . vectorp)
 
528
    (bit-vector . bit-vector-p)
 
529
    (string . stringp)
 
530
    (list . (lambda (y) (or (consp y) (null y))))
 
531
    (number . numberp)
 
532
    (rational . rationalp)
 
533
    (complex . complexp)
 
534
    (ratio . ratiop)
 
535
    (sequence . (lambda (y) (or (listp y) (vectorp y))))
 
536
    (function . functionp)
 
537
    ))
 
538
 
 
539
 
 
540
(defun co1typep (f args &aux tem) f
 
541
  (let*
 
542
      ((x (car args))  new
 
543
       (type (and (consp (second args))
 
544
                  (eq (car (second args)) 'quote)
 
545
                  (second (second args)))))
 
546
    (cond ((subtypep (result-type (car args)) type)
 
547
           (setq new t)
 
548
           (return-from co1typep (c1expr new))))
 
549
    (setq new
 
550
          (cond
 
551
           ((null type) nil)
 
552
           ((setq f (assoc type *type-alist* :test 'equal))
 
553
            (list (cdr f) x))
 
554
           ((and (consp type)
 
555
                 (or (and (eq (car type) 'vector)
 
556
                          (null (cddr type)))
 
557
                     (and 
 
558
                      (member (car type)
 
559
                              '(array vector simple-array))
 
560
                      (equal (third type) '(*)))))
 
561
            (setq tem (si::best-array-element-type
 
562
                       (second type)))
 
563
            (cond ((eq tem 'string-char) `(stringp ,x))
 
564
                  ((eq tem 'bit) `(bit-vector-p ,x))
 
565
                  ((setq tem (position tem *aet-types*))
 
566
                   `(the boolean (vector-type ,x ,tem)))))
 
567
           ((and (consp type)
 
568
                 (eq (car type) 'satisfies)
 
569
                 (consp (cdr type))
 
570
                 (cadr type)
 
571
                 (symbolp (cadr type))
 
572
                 (symbol-package (cadr type))
 
573
                 (null (cddr type))
 
574
                 `(,(cadr type) ,x)))
 
575
           ((subtypep type 'fixnum)
 
576
            (setq tem (si::normalize-type type))
 
577
            (and (consp tem)
 
578
                 (si::fixnump (second tem))
 
579
                 (si::fixnump (third  tem))
 
580
                 `(let ((.tem ,x))
 
581
                    (declare (type ,(result-type x) .tem))
 
582
                    (and (typep .tem 'fixnum)
 
583
                         (>=  (the fixnum .tem) ,(second tem))
 
584
                         (<=  (the fixnum .tem) ,(third tem))))))
 
585
           ((and (symbolp type)
 
586
                 (setq tem (get type 'si::s-data)))
 
587
            (cond ((or (si::s-data-frozen tem)
 
588
                       *frozen-defstructs*)
 
589
                   (struct-type-opt x tem))
 
590
                  (t
 
591
                   `(si::structure-subtype-p
 
592
                     ,x ',type))))
 
593
;          ((and (print (list 'slow 'typep type)) nil))
 
594
           (t nil)))
 
595
    (and new (c1expr `(the boolean , new)))))
 
596
 
 
597
;; this is going the wrong way.  want to go up..
 
598
(defun struct-type-opt (x sd)
 
599
  (let ((s (gensym))
 
600
        (included (get-included (si::s-data-name sd))))
 
601
    `(let ((,s ,x))
 
602
       (and
 
603
         (si::structurep ,s)
 
604
         ,(cond ((< (length included) 3)
 
605
                 `(or ,@
 
606
                      (mapcar #'(lambda (x)
 
607
                                  `(eq (si::structure-def ,s)
 
608
                                       ,(name-sd1 x)))
 
609
                              included)))
 
610
                (t `(si::structure-subtype-p ,s
 
611
                                            ,(name-sd1
 
612
                                               (si::s-data-name sd)))))))))
 
613
 
 
614
(defun get-included (name)
 
615
  (let ((sd (get name 'si::s-data)))
 
616
    (cons (si::s-data-name sd)
 
617
          (mapcan 'get-included
 
618
                  (si::s-data-included sd)))))
 
619
  
 
620
 
 
621
 
 
622
(si::putprop 'typep 'co1typep 'co1)                 
 
623
 
 
624
(defun co1schar (f args) f
 
625
   (and (listp (car args)) (not *safe-compile*)
 
626
        (cdr args)
 
627
        (eq (caar args) 'symbol-name)
 
628
        (c1expr `(aref (the string ,(second (car args)))
 
629
                        ,(second args)))))
 
630
 
 
631
(si::putprop 'schar 'co1schar 'co1)
 
632
 
 
633
(si::putprop 'cons 'co1cons 'co1)
 
634
;; turn repetitious cons's into a list*
 
635
 
 
636
(defun cons-to-lista (x)
 
637
  (let ((tem  (last x)))
 
638
    (cond 
 
639
        ((and (consp tem)
 
640
             (consp (car tem))
 
641
             (eq (caar tem) 'cons)
 
642
             (eql (length (cdar tem)) 2)
 
643
             (cons-to-lista (append (butlast x)
 
644
                                    (cdar tem)))))
 
645
        (t x))))
 
646
         
 
647
 
 
648
(defun co1cons (f args) f
 
649
  (let ((tem (and (eql (length args) 2) (cons-to-lista args))))
 
650
    (and (not (eq tem args))
 
651
         (c1expr  (if (equal '(nil) (last tem))
 
652
                     (cons 'list (butlast tem))
 
653
                     (cons 'list* tem))))))
 
654
 
 
655
;; I don't feel it is good to replace the list call, but rather
 
656
;; usually better the other way around.  We removed c1list
 
657
;; because of possible feedback.
 
658
 
 
659
(defun c1nth-condition (args)
 
660
       (and (not (endp args))
 
661
            (not (endp (cdr args)))
 
662
            (endp (cddr args))
 
663
            (numberp (car args))
 
664
            (<= 0 (car args) 7)))
 
665
 
 
666
(defun c1nth (args)
 
667
       (c1expr (case (car args)
 
668
                     (0 (cons 'car (cdr args)))
 
669
                     (1 (cons 'cadr (cdr args)))
 
670
                     (2 (cons 'caddr (cdr args)))
 
671
                     (3 (cons 'cadddr (cdr args)))
 
672
                     (4 (list 'car (cons 'cddddr (cdr args))))
 
673
                     (5 (list 'cadr (cons 'cddddr (cdr args))))
 
674
                     (6 (list 'caddr (cons 'cddddr (cdr args))))
 
675
                     (7 (list 'cadddr (cons 'cddddr (cdr args))))
 
676
                     )))
 
677
 
 
678
(defun c1nthcdr-condition (args)
 
679
       (and (not (endp args))
 
680
            (not (endp (cdr args)))
 
681
            (endp (cddr args))
 
682
            (numberp (car args))
 
683
            (<= 0 (car args) 7)))
 
684
 
 
685
(defun c1nthcdr (args)
 
686
       (c1expr (case (car args)
 
687
                     (0 (cadr args))
 
688
                     (1 (cons 'cdr (cdr args)))
 
689
                     (2 (cons 'cddr (cdr args)))
 
690
                     (3 (cons 'cdddr (cdr args)))
 
691
                     (4 (cons 'cddddr (cdr args)))
 
692
                     (5 (list 'cdr (cons 'cddddr (cdr args))))
 
693
                     (6 (list 'cddr (cons 'cddddr (cdr args))))
 
694
                     (7 (list 'cdddr (cons 'cddddr (cdr args))))
 
695
                     )))
 
696
 
 
697
(defun c1rplaca-nthcdr (args &aux (info (make-info)))
 
698
  (when (or (endp args) (endp (cdr args)) (endp (cddr args)))
 
699
        (too-few-args 'si:rplaca-nthcdr 3 (length args)))
 
700
  (unless (endp (cdddr args))
 
701
          (too-few-args 'si:rplaca-nthcdr 3 (length args)))
 
702
  (if (and (numberp (cadr args)) (<= 0 (cadr args) 10))
 
703
      (let  ((x (gensym))(y (gensym)))
 
704
        (c1expr
 
705
         `(let ((,x ,(car args))
 
706
                (,y ,(third args)))
 
707
            (setf ,x (nthcdr ,(cadr args) ,x))
 
708
            (setf (car ,x) ,y)
 
709
            ,y)))
 
710
      (list 'call-global info 'si:rplaca-nthcdr (c1args args info))))
 
711
 
 
712
 
 
713
;; Facilities for faster reading and writing from file streams.
 
714
;; You must declare the stream to be :in-file
 
715
;; or :out-file
 
716
 
 
717
(si::putprop 'read-byte 'co1read-byte 'co1)
 
718
(si::putprop 'read-char 'co1read-char 'co1)
 
719
(si::putprop 'write-byte 'co1write-byte 'co1)
 
720
(si::putprop 'write-char 'co1write-char 'co1)
 
721
 
 
722
 
 
723
 
 
724
(defun fast-read (args read-fun)
 
725
  (cond
 
726
    ((and (not *safe-compile*)
 
727
          (< *space* 2)
 
728
          (null (second args))
 
729
          (boundp 'si::*eof*))
 
730
     (cond
 
731
       ((atom (car args))
 
732
        (or (car args) (setq args (cons '*standard-input* (cdr args))))
 
733
        (let ((stream (car args))
 
734
              (eof (third args)))
 
735
          `(let ((ans 0))
 
736
             (declare (fixnum  ans))
 
737
             (cond ((fp-okp ,stream)
 
738
                    (setq ans  (sgetc1 ,stream))
 
739
                    (cond ((and (eql ans ,si::*eof*)
 
740
                                (sfeof  ,stream))
 
741
                           ,eof)
 
742
                          (t ,(if (eq read-fun 'read-char1)
 
743
                                       '(code-char ans) 'ans))
 
744
                          ))
 
745
                   (t
 
746
                    (,read-fun ,stream  ,eof)
 
747
                     )
 
748
                   ))))
 
749
       (t
 
750
        `(let ((.strm. ,(car args)))
 
751
           (declare (type ,(result-type (car args)) .strm.))
 
752
             ,(fast-read (cons '.strm. (cdr args)) read-fun)))))))
 
753
 
 
754
(defun co1read-byte (f args &aux tem) f
 
755
  (cond ((setq tem (fast-read args 'read-byte1))
 
756
         (let ((*space* 10))            ;prevent recursion!
 
757
           (c1expr tem)))))
 
758
 
 
759
(defun co1read-char (f args &aux tem) f
 
760
  (cond ((setq tem (fast-read args 'read-char1))
 
761
         (let ((*space* 10))            ;prevent recursion!
 
762
           (c1expr tem)))))    
 
763
 
 
764
(defun cfast-write (args write-fun)
 
765
  (cond
 
766
    ((and (not *safe-compile*)
 
767
          (< *space* 2)
 
768
          (boundp 'si::*eof*))
 
769
     (let ((stream (second args)))
 
770
       (or stream (setq stream '*standard-output*))
 
771
     (cond
 
772
       ((atom stream)
 
773
        `(cond ((fp-okp ,stream)
 
774
                (the fixnum (sputc .ch ,stream)))
 
775
               (t    (,write-fun  .ch ,stream))))
 
776
       (t `(let ((.str ,stream))
 
777
             (declare (type ,(result-type stream) .str))
 
778
             ,(cfast-write (list '.ch '.str) write-fun))))))))
 
779
 
 
780
(defun co1write-byte (f args) f
 
781
  (let ((tem (cfast-write args 'write-byte)))
 
782
    (if tem (let ((*space* 10))
 
783
              (c1expr
 
784
                `(let ((.ch ,(car args)))
 
785
                   (declare (fixnum .ch))
 
786
                   ,tem
 
787
                   ,(if (atom (car args)) (car args) '.ch)))))))
 
788
 
 
789
(defun co1write-char (f args) f
 
790
  (let ((tem (cfast-write args 'write-char)))
 
791
    (if tem (let ((*space* 10))
 
792
              (c1expr
 
793
                `(let ((.ch ,(car args)))
 
794
                   (declare (character .ch))
 
795
                   ,tem
 
796
                   ,(if (atom (car args)) (car args) '.ch)))))))
 
797
 
 
798
 
 
799
 
 
800
(defvar *aet-types*
 
801
  #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT
 
802
                        SIGNED-CHAR
 
803
                        UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT))
 
804
 
 
805
 
 
806
(defun aet-c-type (type)
 
807
  (ecase type
 
808
    ((t) "object")
 
809
    ((string-char signed-char) "char")
 
810
    (fixnum "fixnum")
 
811
    (unsigned-char "unsigned char")
 
812
    (unsigned-short "unsigned short")
 
813
    (signed-short "short")
 
814
    (unsigned-short "unsigned short")
 
815
    (long-float "longfloat")
 
816
    (short-float "shortfloat")))
 
817
 
 
818
 
 
819
(si:putprop 'vector-push 'co1vector-push 'co1)
 
820
(si:putprop 'vector-push-extend 'co1vector-push 'co1)
 
821
(defun co1vector-push (f args) f
 
822
  (unless
 
823
   (or *safe-compile*
 
824
       (> *space* 3)
 
825
       (null (cdr args))
 
826
       )
 
827
   (let ((*space* 10))
 
828
     (c1expr
 
829
      `(let* ((.val ,(car args))
 
830
              (.v ,(second args))
 
831
              (.i (fill-pointer .v))
 
832
              (.dim (array-total-size .v)))
 
833
         (declare (fixnum .i .dim))
 
834
         (declare (type ,(result-type (second args)) .v))
 
835
         (declare (type ,(result-type (car args)) .val))
 
836
         (cond ((< .i .dim)
 
837
                (the fixnum (si::fill-pointer-set .v (the fixnum (+ 1 .i))))
 
838
                (si::aset .v .i .val)
 
839
                .i)
 
840
               (t ,(cond ((eq f 'vector-push-extend)
 
841
                          `(vector-push-extend .val
 
842
                                               .v ,@(cddr args)))))))))))
 
843
 
 
844
(defun constant-fold-p (x)
 
845
  (cond ((constantp x) t)
 
846
        ((atom  x) nil)
 
847
        ((eq (car x) 'the)
 
848
         (constant-fold-p (third x)))
 
849
        ((and 
 
850
              (symbolp (car x))
 
851
              (eq (get (car x) 'co1)
 
852
                  'co1constant-fold))
 
853
         (dolist (w (cdr x))
 
854
                 (or (constant-fold-p w)
 
855
                     (return-from constant-fold-p nil)))
 
856
         t)
 
857
        (t nil)))
 
858
 
 
859
(defun co1constant-fold (f args )
 
860
  (cond ((and (fboundp f)
 
861
              (dolist (v args t)
 
862
                      (or (constant-fold-p v)
 
863
                          (return-from co1constant-fold nil))))
 
864
         (c1expr (cmp-eval (cons f args))))))
 
865
 
 
866
 
 
867
(si::putprop 'do 'co1special-fix-decl 'co1special)
 
868
(si::putprop 'do* 'co1special-fix-decl 'co1special)
 
869
(si::putprop 'prog 'co1special-fix-decl 'co1special)
 
870
(si::putprop 'prog* 'co1special-fix-decl 'co1special)
 
871
 
 
872
(defun co1special-fix-decl (f args)
 
873
  (flet ((fixup (forms &aux decls )
 
874
          (block nil
 
875
                 (tagbody
 
876
                  top
 
877
                  (or (consp forms) (go end))
 
878
                  (let ((tem (car forms)))
 
879
                    (if (and (consp tem)
 
880
                             (setq tem  (cmp-macroexpand tem))
 
881
                             (eq (car tem) 'declare))
 
882
                        (progn (push tem decls) (pop forms))
 
883
                      (go end)))
 
884
                      (go top)
 
885
                        ; all decls made explicit.
 
886
                      end
 
887
                     (return  (nconc (nreverse decls) forms))))))
 
888
        (c1expr
 
889
          (cmp-macroexpand
 
890
            (case f
 
891
              ((do do*) `(,f ,(car args)
 
892
                             ,(second args)
 
893
                             ,@ (fixup (cddr args))))
 
894
              ((prog prog*)
 
895
               `(,f ,(car args)
 
896
                    ,@ (fixup (cdr args)))))))))
 
897
(si::putprop 'sublis 'co1sublis 'co1)
 
898
(defun co1sublis (f args &aux test) f
 
899
 (and (case (length args)
 
900
        (2 (setq test 'eql))
 
901
        (4 (and (eq (third args) :test)
 
902
                (cond ((member (fourth args) '(equal (function equal))) (setq test 'equal))
 
903
                      ((member (fourth args) '(eql (function eql))) (setq test 'eql))
 
904
                      ((member (fourth args) '(eq (function eq))) (setq test 'eq))
 
905
                      ))))
 
906
      (let ((s (gensym)))
 
907
        (c1expr `(let ((,s ,(car args)))
 
908
                   (sublis1 ,s ,(second args) ',test))))))
 
909
 
 
910
 
 
911
(defun sublis1-inline (a b c)
 
912
  (let ((tst (car (find (cadr c) *objects* :key 'cadr))))
 
913
    (or (member tst '(eq equal eql)) (error "bad test"))
 
914
  (wt "(check_alist("
 
915
      a
 
916
     "),sublis1("a "," b "," (format nil "~(&~a~)))" tst))))
 
917
 
 
918
  
 
919
;; end new                
 
920
      
 
921
(defun c1list-nth (args &aux (info (make-info)))
 
922
  (when (or (endp args) (endp (cdr args)))
 
923
        (too-few-args 'si:rplaca-nthcdr 2 (length args)))
 
924
  (unless (endp (cddr args))
 
925
          (too-few-args 'si:rplaca-nthcdr 2 (length args)))
 
926
  (if (and (numberp (car args)) (<= 0 (car args) 10))
 
927
      (list 'list-nth-immediate info
 
928
            (car args)
 
929
            (c1args (list (cadr args)) info))
 
930
      (list 'call-global info 'si:list-nth (c1args args info))))
 
931
 
 
932
(defun c2list-nth-immediate (index args &aux (l (next-cvar))
 
933
                                             (*vs* *vs*) (*inline-blocks* 0))
 
934
  (setq args (inline-args args '(t t)))
 
935
  (wt-nl "{object V" l "= ")
 
936
  (if *safe-compile*
 
937
      (progn
 
938
       (dotimes** (i index) (wt "cdr("))
 
939
       (wt (car args))
 
940
       (dotimes** (i index) (wt ")"))
 
941
       (wt ";")
 
942
       (wt-nl "if((type_of(V" l ")!=t_cons) && (" (car args) "!= Cnil))")
 
943
       (wt-nl " FEwrong_type_argument(Scons,V" l ");")
 
944
       )
 
945
      (progn
 
946
       (wt-nl (car args))
 
947
       (dotimes** (i index) (wt-nl "->c.c_cdr"))
 
948
       (wt ";")))
 
949
  (unwind-exit (list 'CAR l))
 
950
  (wt "}")
 
951
  (close-inline-blocks)
 
952
  )
 
953
 
 
954