← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmpenv.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Albin Tonnerre
  • Date: 2008-06-20 18:00:19 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20080620180019-7fbz1ln5444vtkkr
Tags: 0.9j-20080306-2ubuntu1
* Enabled unicode support. (Closes: LP #123530)
* Modify Maintainer value to match the DebianMaintainerField specification.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmpenv.lsp
 
1
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 
2
;;;;
1
3
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
2
4
;;;;  Copyright (c) 1990, Giuseppe Attardi.
3
5
;;;;
89
91
               (t (type-filter (cadar return-types)))))
90
92
        (t (type-filter (car return-types)))))
91
93
 
92
 
(defun add-function-proclamation (fname decl &aux
93
 
         arg-types return-types)
94
 
  (cond ((and (symbolp fname)
95
 
              (listp decl) (listp (cdr decl)))
96
 
         (cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '*)
97
 
                (rem-sysprop fname 'PROCLAIMED-ARG-TYPES))
98
 
               (t (setq arg-types (function-arg-types (car decl)))
99
 
                  (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)))
100
 
         (cond ((or (null (cdr decl))(eq (second decl) '*))
101
 
                (setq return-types '*))
102
 
               (t (setq return-types (function-return-type (cdr decl)))))
103
 
         (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)
104
 
         (cond((eql return-types '*))
105
 
              (t(setq return-types (cdr decl))))
106
 
         ;;; A non-local function may have local entry only if it returns
107
 
         ;;; a single value.
108
 
         (if (and (not (endp return-types))
109
 
                  (endp (cdr return-types))
110
 
                  (not (and (consp (car return-types))
111
 
                            (eq (caar return-types) 'VALUES)
112
 
                            (or (endp (cdar return-types))
113
 
                                (not (endp (cddar return-types)))))))
114
 
             (put-sysprop fname 'PROCLAIMED-FUNCTION t)
115
 
           (rem-sysprop fname 'PROCLAIMED-FUNCTION)))
116
 
        (t (warn "The function procl ~s ~s is not valid." fname decl))))
 
94
(defun add-function-proclamation (fname decl)
 
95
  (if (symbolp fname)
 
96
      (let* ((arg-types '*)
 
97
             (return-types '*)
 
98
             (l decl))
 
99
        (cond ((null l))
 
100
              ((consp l)
 
101
               (setf arg-types (pop l)))
 
102
              (t (warn "The function proclamation ~s ~s is not valid."
 
103
                       fname decl)))
 
104
        (cond ((null l))
 
105
              ((and (consp l) (null (rest l)))
 
106
               (setf return-types (function-return-type l)))
 
107
              (t (warn "The function proclamation ~s ~s is not valid."
 
108
                       fname decl)))
 
109
        (if (eq arg-types '*)
 
110
            (rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
 
111
            (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
 
112
        (if (eq return-types '*)
 
113
            (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
 
114
            (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
 
115
      (warn "The function proclamation ~s ~s is not valid." fname decl)))
117
116
 
118
117
(defun add-function-declaration (fname arg-types return-types)
119
118
  (if (si::valid-function-name-p fname)
163
162
;;; Proclamation and declaration handling.
164
163
 
165
164
(defun inline-possible (fname)
166
 
  (not (or ; (compiler-push-events)
 
165
  (not (or ; (compiler-<push-events)
 
166
        ;(>= *debug* 2) Breaks compilation of STACK-PUSH-VALUES
167
167
        (member fname *notinline* :test #'same-fname-p)
168
168
        (and (symbolp fname) (get-sysprop fname 'CMP-NOTINLINE)))))
169
169
 
186
186
               (not (<= 0 (second x) 3)))
187
187
           (warn "The OPTIMIZE proclamation ~s is illegal." x)
188
188
           (case (car x)
189
 
                 (DEBUG)
 
189
                 (DEBUG (setq *debug* (second x)))
190
190
                 (SAFETY (setq *safety* (second x)))
191
191
                 (SPACE (setq *space* (second x)))
192
192
                 (SPEED (setq *speed* (second x)))
346
346
  (values body ss ts is others doc all-declarations)
347
347
  )
348
348
 
 
349
(defun default-optimization (optimization)
 
350
  (ecase optimization
 
351
    (speed *speed*)
 
352
    (safety *safety*)
 
353
    (space *space*)
 
354
    (debug *debug*)))
 
355
 
 
356
(defun search-optimization-quality (declarations what)
 
357
  (dolist (i (reverse declarations)
 
358
           (default-optimization what))
 
359
    (when (and (consp i) (eq (first i) 'optimize))
 
360
      (dolist (j (rest i))
 
361
        (cond ((consp j)
 
362
               (when (eq (first j) what) (return (second j))))
 
363
              ((eq j what)
 
364
               (return 3)))))))
 
365
 
349
366
(defun c1add-declarations (decls &aux (dl nil))
350
367
  (dolist (decl decls dl)
351
368
    (case (car decl)
359
376
                 (not (<= 0 (second x) 3)))
360
377
           (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
361
378
           (case (car x)
362
 
             (DEBUG)
 
379
             (DEBUG (setq *debug* (second x)))
363
380
             (SAFETY (setq *safety* (second x)))
364
381
             (SPACE (setq *space* (second x)))
365
382
             ((SPEED COMPILATION-SPEED))
403
420
             (*safety* *safety*)
404
421
             (*space* *space*)
405
422
             (*speed* *speed*)
 
423
             (*debug* *debug*)
406
424
             (dl (c1add-declarations decls)))
407
425
        (setq body (c1progn body))
408
426
        (make-c1form 'DECL-BODY body dl body))))
413
431
  (let ((*safety* *safety*)
414
432
        (*space* *space*)
415
433
        (*speed* *speed*)
 
434
        (*debug* *debug*)
416
435
        (*notinline* *notinline*))
417
436
    (c1add-declarations decls)
418
437
    (c2expr body)))