← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/lsp/export.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/lsp/export.lsp
 
1
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
2
;;;;  Copyright (c) 1990, Giuseppe Attardi.
 
3
;;;;
 
4
;;;;    This program is free software; you can redistribute it and/or
 
5
;;;;    modify it under the terms of the GNU Library General Public
 
6
;;;;    License as published by the Free Software Foundation; either
 
7
;;;;    version 2 of the License, or (at your option) any later version.
 
8
;;;;
 
9
;;;;    See file '../Copyright' for full details.
 
10
;;;;                    Exporting external symbols of LISP package
 
11
 
 
12
(eval-when (eval compile load)
 
13
  (si::select-package "SI"))
 
14
 
 
15
;;; ----------------------------------------------------------------------
 
16
;;;
 
17
(*make-special '*dump-defun-definitions*)
 
18
(setq *dump-defun-definitions* nil)
 
19
(*make-special '*dump-defmacro-definitions*)
 
20
(setq *dump-defmacro-definitions* *dump-defun-definitions*)
 
21
 
 
22
;; This is needed only when bootstrapping ECL using ECL-MIN
 
23
(eval-when (eval)
 
24
  (si::fset 'defun
 
25
          #'(ext::lambda-block defun (def env)
 
26
              (let* ((name (second def))
 
27
                     (function `#'(ext::lambda-block ,@(cdr def))))
 
28
                (when *dump-defun-definitions*
 
29
                  (print function)
 
30
                  (setq function `(si::bc-disassemble ,function)))
 
31
                `(si::fset ',name ,function)))
 
32
          t)
 
33
 (si::fset 'in-package
 
34
          #'(ext::lambda-block in-package (def env)
 
35
              `(eval-when (eval compile load)
 
36
                (si::select-package ,(string (second def)))))
 
37
          t)
 
38
)
 
39
 
 
40
;;
 
41
;; This is also needed for booting ECL. In particular it is required in
 
42
;; defmacro.lsp.
 
43
;;
 
44
(let ((f #'(ext::lambda-block dolist (whole env)
 
45
           (let (body pop finished control var expr exit)
 
46
             (setq body (rest whole))
 
47
             (when (endp body)
 
48
               (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole))
 
49
             (setq control (first body) body (rest body))
 
50
             (when (endp control)
 
51
               (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole))
 
52
             (setq var (first control) control (rest control))
 
53
             (if (<= 1 (length control) 2)
 
54
                 (setq expr (first control) exit (rest control))
 
55
                 (simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole))
 
56
             (multiple-value-bind (declarations body)
 
57
                 (process-declarations body nil)
 
58
               `(block nil
 
59
                 (let* ((%dolist-var ,expr)
 
60
                        ,var)
 
61
                   (declare ,@declarations)
 
62
                   (si::while %dolist-var
 
63
                      (setq ,var (first %dolist-var))
 
64
                      ,@body
 
65
                      (setq %dolist-var (rest %dolist-var)))
 
66
                   ,(when exit `(setq ,var nil))
 
67
                   ,@exit)))))))
 
68
  (si::fset 'dolist f t))
 
69
 
 
70
(let ((f #'(ext::lambda-block dotimes (whole env)
 
71
           (let (body pop finished control var expr exit)
 
72
             (setq body (rest whole))
 
73
             (when (endp body)
 
74
               (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole))
 
75
             (setq control (first body) body (rest body))
 
76
             (when (endp control)
 
77
               (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole))
 
78
             (setq var (first control) control (rest control))
 
79
             (if (<= 1 (length control) 2)
 
80
                 (setq expr (first control) exit (rest control))
 
81
                 (simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole))
 
82
             (multiple-value-bind (declarations body)
 
83
                 (process-declarations body nil)
 
84
               `(block nil
 
85
                 (let* ((%dotimes-var ,expr)
 
86
                        (,var 0))
 
87
                   (declare ,@declarations)
 
88
                   (si::while (< ,var %dotimes-var)
 
89
                     ,@body
 
90
                     (setq ,var (1+ ,var)))
 
91
                   ,@exit)))))))
 
92
  (si::fset 'dotimes f t))
 
93
 
 
94
(let ((f #'(ext::lambda-block do/do*-expand (whole env)
 
95
           (let (do/do* control test result vl step let psetq body)
 
96
             (setq do/do* (first whole) body (rest whole))
 
97
             (if (eq do/do* 'do)
 
98
                 (setq let 'LET psetq 'PSETQ)
 
99
                 (setq let 'LET* psetq 'SETQ))
 
100
             (when (endp body)
 
101
               (simple-program-error "Syntax error in ~A:~%~A" do/do* whole))
 
102
             (setq control (first body) body (rest body))
 
103
             (when (endp body)
 
104
               (simple-program-error "Syntax error in ~A:~%~A" do/do* whole))
 
105
             (setq test (first body) body (rest body))
 
106
             (when (endp test)
 
107
               (simple-program-error "Syntax error in ~A:~%~A" do/do* whole))
 
108
             (setq result (rest test) test (first test))
 
109
             (dolist (c control)
 
110
               (when (symbolp c) (setq c (list c)))
 
111
               (case (length c)
 
112
                 ((1 2)
 
113
                  (setq vl (cons c vl)))
 
114
                 ((3)
 
115
                  (setq vl (cons (butlast c) vl)
 
116
                        step (list* (third c) (first c) step)))
 
117
                 (t
 
118
                  (simple-program-error "Syntax error in ~A:~%~A" do/do* whole))))
 
119
             (multiple-value-bind (declarations real-body)
 
120
                 (process-declarations body nil)
 
121
               `(BLOCK NIL
 
122
                 (,let ,(nreverse vl)
 
123
                   (declare ,@declarations)
 
124
                   (sys::until ,test
 
125
                      ,@real-body
 
126
                      ,@(when step (list (cons psetq (nreverse step)))))
 
127
                   ,@(or result '(nil)))))))))
 
128
  (si::fset 'do f t)
 
129
  (si::fset 'do* f t))
 
130
 
 
131
(defun eval-feature (x &aux operator)
 
132
  (declare (si::c-local))
 
133
  (cond ((symbolp x)
 
134
         (and (member x *features* :test #'eq) t))
 
135
        ((atom x) (error "~ is not allowed as a feature" x))
 
136
        ((not (symbolp (setq operator (first x))))
 
137
         (error "~S is not a valid feature expression." x))
 
138
        ((eql operator :AND)
 
139
         (dolist (x (cdr x) t) (when (not (eval-feature x)) (return nil))))
 
140
        ((eql operator :OR)
 
141
         (dolist (x (cdr x) nil) (when (eval-feature x) (return t))))
 
142
        ((eql operator :NOT)
 
143
         (not (eval-feature (second x))))
 
144
        (t (error "~S is not a valid feature expression." x))))
 
145
 
 
146
(defun do-read-feature (stream subchar arg test)
 
147
  (declare (si::c-local))
 
148
  (when arg
 
149
    (error "Reading from ~S: no number should appear between # and ~A"
 
150
           stream subchar))
 
151
  (let ((feature (let ((*package* (find-package "KEYWORD")))
 
152
                   (read stream t nil t))))
 
153
    (if (and (not *read-suppress*) (eq (eval-feature feature) test))
 
154
        (read stream t nil t)
 
155
        (let ((*read-suppress* t)) (read stream t nil t) (values)))))
 
156
 
 
157
(defun sharp-+-reader (stream subchar arg)
 
158
  (do-read-feature stream subchar arg T))
 
159
 
 
160
(defun sharp---reader (stream subchar arg)
 
161
  (do-read-feature stream subchar arg NIL))
 
162
 
 
163
(set-dispatch-macro-character #\# #\+ 'sharp-+-reader)
 
164
(set-dispatch-macro-character #\# #\+ 'sharp-+-reader (sys::standard-readtable))
 
165
 
 
166
(set-dispatch-macro-character #\# #\- 'sharp---reader)
 
167
(set-dispatch-macro-character #\# #\- 'sharp---reader (sys::standard-readtable))