← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/cmp/cmptop.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/cmptop.lsp
 
1
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 
2
;;;;
1
3
;;;;  CMPTOP  --  Compiler top-level.
2
4
 
3
5
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
103
105
  ;; and rather inline it.
104
106
  (do ()
105
107
      ((null *clines-string-list*))
106
 
    (wt-h (pop *clines-string-list*)))
107
 
  (wt-h "#ifdef __cplusplus")
108
 
  (wt-h "extern \"C\" {")
109
 
  (wt-h "#endif")
 
108
    (wt-nl-h (pop *clines-string-list*)))
 
109
  (wt-nl-h "#ifdef __cplusplus")
 
110
  (wt-nl-h "extern \"C\" {")
 
111
  (wt-nl-h "#endif")
110
112
  (when si::*compiler-constants*
111
 
    (wt-h "#include <string.h>"))
 
113
    (wt-nl-h "#include <string.h>"))
112
114
  ;;; Initialization function.
113
115
  (let* ((*lcl* 0) (*lex* 0) (*max-lex* 0) (*max-env* 0) (*max-temp* 0)
114
116
         (*reservation-cmacro* (next-cmacro))
115
117
         (c-output-file *compiler-output1*)
116
118
         (*compiler-output1* (make-string-output-stream))
117
119
         (*emitted-local-funs* nil)
118
 
         (*compiler-declared-globals* (make-hash-table))
119
 
         #+PDE (optimize-space (>= *space* 3)))
 
120
         (*compiler-declared-globals* (make-hash-table)))
120
121
    (unless shared-data
121
122
      (wt-nl1 "#include \"" (si::coerce-to-filename data-pathname) "\""))
122
123
    (wt-nl1 "#ifdef __cplusplus")
123
124
    (wt-nl1 "extern \"C\"")
124
125
    (wt-nl1 "#endif")
125
126
    (wt-nl1 "void " name "(cl_object flag)")
126
 
    (wt-nl1 "{ VT" *reservation-cmacro* " CLSR" *reservation-cmacro*)
 
127
    (wt-nl1 "{ VT" *reservation-cmacro* " VLEX" *reservation-cmacro*
 
128
            " CLSR" *reservation-cmacro*)
127
129
    (wt-nl "cl_object value0;")
128
130
    (wt-nl "cl_object *VVtemp;")
129
131
    (when shared-data
144
146
      (wt-nl "return;}")
145
147
      (wt-nl "#ifdef ECL_DYNAMIC_VV")
146
148
      (wt-nl "VV = Cblock->cblock.data;")
147
 
      (wt-nl "#endif"))
 
149
      (wt-nl "#endif")
 
150
      ;; With this we ensure creating a constant with the tag
 
151
      ;; and the initialization file
 
152
      (wt-nl "Cblock->cblock.data_text = \"" (init-name-tag name) "\";")
 
153
      )
148
154
    (when si::*compiler-constants*
149
155
      (wt-nl "{cl_object data = ecl_symbol_value("
150
156
             (nth-value 1 (si::mangle-name '*compiler-constants* nil))
166
172
    (setq top-output-string (get-output-stream-string *compiler-output1*)))
167
173
 
168
174
  ;; Declarations in h-file.
169
 
  (wt-h "static cl_object Cblock;")
 
175
  (wt-nl-h "static cl_object Cblock;")
170
176
  (dolist (x *reservations*)
171
 
    (wt-h "#define VM" (car x) " " (cdr x)))
 
177
    (wt-nl-h "#define VM" (car x) " " (cdr x)))
172
178
  (let ((num-objects (data-size)))
173
179
    (if (zerop num-objects)
174
180
        (progn
175
 
          (wt-h "#undef ECL_DYNAMIC_VV")
176
 
          (wt-h "#define compiler_data_text \"\"")
177
 
          (wt-h "#define compiler_data_text_size 0")
178
 
          (wt-h "#define VM 0")
179
 
          (wt-h "#define VMtemp 0")
180
 
          (wt-h "#define VV NULL"))
 
181
          (wt-nl-h "#undef ECL_DYNAMIC_VV")
 
182
          (wt-nl-h "#define compiler_data_text \"\"")
 
183
          (wt-nl-h "#define compiler_data_text_size 0")
 
184
          (wt-nl-h "#define VM 0")
 
185
          (wt-nl-h "#define VMtemp 0")
 
186
          (wt-nl-h "#define VV NULL"))
181
187
        (progn
182
 
          (wt-h "#define VM " (data-permanent-storage-size))
183
 
          (wt-h "#define VMtemp "  (data-temporary-storage-size))
184
 
          (wt-h "#ifdef ECL_DYNAMIC_VV")
185
 
          (wt-h "static cl_object *VV;")
186
 
          (wt-h "#else")
187
 
          (wt-h "static cl_object VV[VM];")
188
 
          (wt-h "#endif"))))
 
188
          (wt-nl-h "#define VM " (data-permanent-storage-size))
 
189
          (wt-nl-h "#define VMtemp "  (data-temporary-storage-size))
 
190
          (wt-nl-h "#ifdef ECL_DYNAMIC_VV")
 
191
          (wt-nl-h "static cl_object *VV;")
 
192
          (wt-nl-h "#else")
 
193
          (wt-nl-h "static cl_object VV[VM];")
 
194
          (wt-nl-h "#endif"))))
189
195
  (dolist (l *linking-calls*)
190
196
    (let* ((c-name (fourth l))
191
197
           (var-name (fifth l)))
192
 
      (wt-h "static cl_object " c-name "(cl_narg, ...);")
193
 
      (wt-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";")))
 
198
      (wt-nl-h "static cl_object " c-name "(cl_narg, ...);")
 
199
      (wt-nl-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";")))
194
200
 
195
201
  ;;; Global entries for directly called functions.
196
202
  (dolist (x *global-entries*)
208
214
 
209
215
  ;;; Callbacks
210
216
  (when *callbacks*
211
 
    (wt-h "#include <ecl/internal.h>")
 
217
    (wt-nl-h "#include <ecl/internal.h>")
212
218
    (dolist (x *callbacks*)
213
219
      (apply #'t3-defcallback x)))
214
220
 
215
 
  (wt-h "#ifdef __cplusplus")
216
 
  (wt-h "}")
217
 
  (wt-h "#endif")
 
221
  (wt-nl-h "#ifdef __cplusplus")
 
222
  (wt-nl-h "}")
 
223
  (wt-nl-h "#endif")
218
224
 
219
225
 
220
226
  (wt-nl top-output-string))
336
342
 
337
343
(defun wt-function-epilogue (&optional closure-type)
338
344
  (push (cons *reservation-cmacro* *max-temp*) *reservations*)
339
 
  (wt-h "#define VT" *reservation-cmacro*)
 
345
  ;; FIXME! Are we careful enough with temporary variables that
 
346
  ;; we need not make them volatile?
 
347
  (wt-nl-h "#define VT" *reservation-cmacro*)
340
348
  (when (plusp *max-temp*)
341
 
    (wt-h1 " cl_object ")
 
349
    (wt-h " cl_object ")
342
350
    (dotimes (i *max-temp*)
343
 
      (wt-h1 "T") (wt-h1 i)
344
 
      (unless (= (1+ i) *max-temp*) (wt-h1 ",")))
345
 
    (wt-h1 ";"))
346
 
;  (wt-h "#define VU" *reservation-cmacro*)
347
 
  (wt-h "#define VLEX" *reservation-cmacro*)
 
351
      (wt-h "T" i)
 
352
      (unless (= (1+ i) *max-temp*) (wt-h ",")))
 
353
    (wt-h ";"))
 
354
;  (wt-nl-h "#define VU" *reservation-cmacro*)
 
355
  (wt-nl-h "#define VLEX" *reservation-cmacro*)
 
356
  ;; There should be no need to mark lex as volatile, since we
 
357
  ;; are going to pass pointers of this array around and the compiler
 
358
  ;; should definitely keep this in memory.
348
359
  (when (plusp *max-lex*)
349
 
    (wt-h1 " cl_object lex") (wt-h1 *level*)
350
 
    (wt-h1 "[") (wt-h1 *max-lex*) (wt-h1 "];"))
351
 
  (wt-h "#define CLSR" *reservation-cmacro*)
 
360
    (wt-h " volatile cl_object lex" *level* "[" *max-lex* "];"))
 
361
  (wt-nl-h "#define CLSR" *reservation-cmacro*)
352
362
  (when (plusp *max-env*)
353
363
    (unless (eq closure-type 'CLOSURE)
354
 
      (wt-h1 " volatile cl_object env0;"))
355
 
    (wt-h1 " cl_object ")
 
364
      (wt-h " cl_object " *volatile* "env0;"))
 
365
    (wt-h " cl_object " *volatile*)
356
366
    (dotimes (i *max-env*)
357
 
      (wt-h1 "CLV") (wt-h1 i)
358
 
      (unless (= (1+ i) *max-env*) (wt-h1 ",")))
359
 
    (wt-h1 ";"))
 
367
      (wt-h "CLV" i)
 
368
      (unless (= (1+ i) *max-env*) (wt-h ",")))
 
369
    (wt-h ";"))
360
370
  )
361
371
 
362
372
(defun wt-global-entry (fname cfun arg-types return-type)
364
374
      (return-from wt-global-entry nil))
365
375
    (wt-comment "global entry for the function " fname)
366
376
    (wt-nl1 "static cl_object L" cfun "(cl_narg narg")
367
 
    (wt-h "static cl_object L" cfun "(cl_narg")
 
377
    (wt-nl-h "static cl_object L" cfun "(cl_narg")
368
378
    (do ((vl arg-types (cdr vl))
369
379
         (lcl (1+ *lcl*) (1+ lcl)))
370
380
        ((endp vl) (wt1 ")"))
371
381
      (declare (fixnum lcl))
372
382
      (wt1 ", cl_object ") (wt-lcl lcl)
373
 
      (wt-h1 ", cl_object"))
 
383
      (wt-h ", cl_object"))
374
384
    (wt-h1 ");")
375
385
    (wt-nl1 "{")
376
386
    (when (compiler-check-args)
468
478
  (let ((*safety* *safety*)
469
479
        (*space* *space*)
470
480
        (*speed* *speed*)
 
481
        (*debug* *debug*)
471
482
        (*notinline* *notinline*))
472
483
    (c1add-declarations decls)
473
484
    (t2expr body)))
513
524
    (wt-comment "... shares definition with " (fun-name (fun-shares-with fun)))
514
525
    (return-from t3local-fun))
515
526
  (cond ((fun-exported fun)
516
 
         (wt-h #+(and msvc (not ecl-min)) "__declspec(dllexport) " "cl_object " cfun "(")
 
527
         (wt-nl-h #+(and msvc (not ecl-min)) "__declspec(dllexport) " "cl_object " cfun "(")
517
528
         (wt-nl1 "cl_object " cfun "("))
518
529
        (t
519
 
         (wt-h "static cl_object " cfun "(")
 
530
         (wt-nl-h "static cl_object " cfun "(")
520
531
         (wt-nl1 "static cl_object " cfun "(")))
521
532
  (let ((comma ""))
522
533
    (when narg
523
 
      (wt-h1 "cl_narg")
524
 
      (wt "cl_narg narg")
 
534
      (wt-h *volatile* "cl_narg")
 
535
      (wt *volatile* "cl_narg narg")
525
536
      (setf comma ", "))
526
537
    (dotimes (n level)
527
 
      (wt-h1 comma) (wt-h1 "cl_object *")
528
 
      (wt comma "cl_object *lex" n)
 
538
      (wt-h comma "volatile cl_object  *")
 
539
      (wt comma "volatile cl_object *lex" n)
529
540
      (setf comma ", "))
530
541
    (when (eq (fun-closure fun) 'CLOSURE)
531
 
      (wt-h1 comma) (wt-h1 "cl_object ")
532
 
      (wt comma "cl_object env0")
 
542
      (wt-h comma "cl_object " *volatile*)
 
543
      (wt comma "cl_object " *volatile* "env0")
533
544
      (setf comma ", "))
534
545
    (let ((lcl 0))
535
546
      (declare (fixnum lcl))
536
547
      (dolist (var requireds)
537
 
        (wt-h1 comma) (wt-h1 "cl_object ")
538
 
        (wt comma "cl_object ") (wt-lcl (incf lcl))
 
548
        (wt-h comma "cl_object " *volatile*)
 
549
        (wt comma "cl_object " *volatile*) (wt-lcl (incf lcl))
539
550
        (setf comma ", ")))
540
551
    (when narg
541
 
      (wt-h1 ", ...")
 
552
      (wt-h ", ...")
542
553
      (wt ", ..."))
543
 
    (wt-h1 ");")
 
554
    (wt-h ");")
544
555
    (wt ")"))
545
556
 
546
557
  (let* ((*lcl* 0) (*temp* 0) (*max-temp* 0)
556
567
    (wt " VT" *reservation-cmacro*
557
568
        " VLEX" *reservation-cmacro*
558
569
        " CLSR" *reservation-cmacro*)
559
 
    (wt-nl "cl_object value0;")
 
570
    (wt-nl *volatile* "cl_object value0;")
 
571
    (when (>= (fun-debug fun) 2)
 
572
      (wt-nl "struct ihs_frame ihs;"))
560
573
    (when (eq (fun-closure fun) 'CLOSURE)
561
574
      (let ((clv-used (remove-if
562
575
                       #'(lambda (x)
590
603
              (pop clv-used)))
591
604
          (wt-nl "{ /* ... closure scanning finished */")
592
605
          (incf *inline-blocks*)))
 
606
    ;; If we ask for high level of debugging information, we push the function
 
607
    ;; name into the invocation stack
 
608
    (when (>= (fun-debug fun) 2)
 
609
      (push 'IHS *unwind-exit*)
 
610
      (wt-nl "ihs_push(&ihs," (add-symbol (fun-name fun)) ");"))
 
611
 
593
612
    (c2lambda-expr (c1form-arg 0 lambda-expr)
594
613
                   (c1form-arg 2 lambda-expr)
595
614
                   (fun-cfun fun) (fun-name fun)