home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / defs3.lsp < prev    next >
Text File  |  1996-04-15  |  16KB  |  300 lines
  1. ;;; CLtL2-kompatible Definitionen
  2. ;;; insbesondere solche, die von CLtL1 abweichen
  3. ;;; Bruno Haible 6.12.1993
  4.  
  5. ;===============================================================================
  6.  
  7. (defpackage "COMMON-LISP"
  8.   (:nicknames "CL")
  9.   (:use "LISP" "CLOS")
  10.   (:shadow "MAKE-PACKAGE" "FLET" "LABELS" "MACROLET")
  11. )
  12.  
  13. (in-package "COMMON-LISP")
  14.  
  15. ;;; Exportierungen:
  16. ;; Nur in ANSI Common Lisp (CLtL2 bzw. dpANS) explizit erwähnte Symbole!
  17. (export '(
  18. ;; Typen:
  19. array atom bignum bit bit-vector character common compiled-function
  20. complex cons double-float fixnum float function hash-table integer keyword
  21. list #+LOGICAL-PATHNAMES logical-pathname long-float nil null number package
  22. pathname random-state ratio rational readtable real sequence short-float
  23. simple-array simple-bit-vector simple-string simple-vector single-float
  24. standard-char stream file-stream synonym-stream broadcast-stream
  25. concatenated-stream two-way-stream echo-stream string-stream string
  26. string-char symbol t vector satisfies values mod signed-byte unsigned-byte
  27. restart condition warning serious-condition error simple-condition
  28. simple-warning simple-error storage-condition type-error simple-type-error
  29. program-error control-error package-error print-not-readable stream-error
  30. end-of-file file-error cell-error unbound-variable undefined-function
  31. arithmetic-error division-by-zero floating-point-overflow
  32. floating-point-underflow
  33. ;; Klassen:
  34. built-in-class standard-class standard-generic-function standard-method
  35. standard-object structure-class
  36. ;; Konstanten:
  37. lambda-list-keywords lambda-parameters-limit nil t call-arguments-limit
  38. multiple-values-limit pi boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2
  39. boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1
  40. boole-andc2 boole-orc1 boole-orc2 most-positive-fixnum most-negative-fixnum
  41. most-positive-short-float least-positive-short-float least-negative-short-float
  42. most-negative-short-float most-positive-single-float
  43. least-positive-single-float least-negative-single-float
  44. most-negative-single-float most-positive-double-float
  45. least-positive-double-float least-negative-double-float
  46. most-negative-double-float most-positive-long-float least-positive-long-float
  47. least-negative-long-float most-negative-long-float
  48. least-positive-normalized-short-float least-negative-normalized-short-float
  49. least-positive-normalized-single-float least-negative-normalized-single-float
  50. least-positive-normalized-double-float least-negative-normalized-double-float
  51. least-positive-normalized-long-float least-negative-normalized-long-float
  52. short-float-epsilon single-float-epsilon double-float-epsilon
  53. long-float-epsilon short-float-negative-epsilon single-float-negative-epsilon
  54. double-float-negative-epsilon long-float-negative-epsilon
  55. char-code-limit char-font-limit char-bits-limit char-control-bit char-meta-bit
  56. char-super-bit char-hyper-bit array-rank-limit array-dimension-limit
  57. array-total-size-limit internal-time-units-per-second
  58. ;; Variablen:
  59. *macroexpand-hook* *gensym-counter* *package* *modules* *random-state*
  60. *evalhook* *applyhook* + ++ +++ - * ** *** / // /// *standard-input*
  61. *standard-output* *error-output* *query-io* *debug-io* *terminal-io*
  62. *trace-output* *read-base* *read-suppress* *readtable* *print-readably*
  63. *print-escape* *print-pretty* *print-circle* *print-base* *print-radix*
  64. *print-case* *print-gensym* *print-level* *print-length* *print-array*
  65. *read-default-float-format* *default-pathname-defaults* *load-verbose*
  66. *load-print* *load-pathname* *load-truename* *break-on-warnings*
  67. *compile-verbose* *compile-print* *compile-file-pathname*
  68. *compile-file-truename* *features* *break-on-signals* *debugger-hook*
  69. ;; Funktionen:
  70. coerce type-of upgraded-array-element-type typep subtypep null symbolp
  71. atom consp listp numberp integerp rationalp floatp realp complexp characterp
  72. stringp bit-vector-p vectorp simple-vector-p simple-string-p
  73. simple-bit-vector-p arrayp packagep functionp compiled-function-p commonp eq
  74. eql equal equalp not symbol-value symbol-function fdefinition boundp fboundp
  75. special-form-p set makunbound fmakunbound get-setf-method
  76. get-setf-method-multiple-value apply funcall mapcar maplist mapc mapl mapcan
  77. mapcon values values-list macro-function macroexpand macroexpand-1 proclaim
  78. get remprop symbol-plist getf get-properties symbol-name make-symbol
  79. copy-symbol gensym gentemp symbol-package keywordp make-package in-package
  80. find-package package-name package-nicknames rename-package package-use-list
  81. package-used-by-list package-shadowing-symbols list-all-packages delete-package
  82. intern find-symbol unintern export unexport import shadowing-import shadow
  83. use-package unuse-package find-all-symbols provide require zerop plusp minusp
  84. oddp evenp = /= < > <= >= max min + - * / 1+ 1- conjugate gcd lcm exp expt
  85. log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh cosh tanh
  86. asinh acosh atanh float rational rationalize numerator denominator floor
  87. ceiling truncate round mod rem ffloor fceiling ftruncate fround decode-float
  88. scale-float float-radix float-sign float-digits float-precision
  89. integer-decode-float complex realpart imagpart logior logxor logand logeqv
  90. lognand lognor logandc1 logandc2 logorc1 logorc2 boole lognot logtest logbitp
  91. ash logcount integer-length byte byte-size byte-position ldb ldb-test mask-field
  92. dpb deposit-field random make-random-state random-state-p standard-char-p
  93. graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p
  94. both-case-p digit-char-p alphanumericp char= char/= char< char> char<= char>=
  95. char-equal char-not-equal char-lessp char-greaterp char-not-greaterp
  96. char-not-lessp char-code char-bits char-font code-char make-char character
  97. char-upcase char-downcase digit-char char-int int-char char-name name-char
  98. char-bit set-char-bit complement constantly elt subseq copy-seq length reverse
  99. nreverse make-sequence concatenate map map-into some every notany notevery
  100. reduce fill replace remove remove-if remove-if-not delete delete-if
  101. delete-if-not remove-duplicates delete-duplicates substitute substitute-if
  102. substitute-if-not nsubstitute nsubstitute-if nsubstitute-if-not find find-if
  103. find-if-not position position-if position-if-not count count-if count-if-not
  104. mismatch search sort stable-sort merge car cdr caar cadr cdar cddr caaar
  105. caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
  106. cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  107. cons tree-equal endp list-length nth first second third fourth fifth sixth
  108. seventh eighth ninth tenth rest nthcdr last list list* make-list append
  109. copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff
  110. rplaca rplacd subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis
  111. nsublis member member-if member-if-not tailp adjoin union nunion intersection
  112. nintersection set-difference nset-difference set-exclusive-or
  113. nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc
  114. rassoc-if rassoc-if-not make-hash-table hash-table-p gethash remhash maphash
  115. clrhash hash-table-count hash-table-rehash-size hash-table-rehash-threshold
  116. hash-table-size hash-table-test sxhash make-array vector aref svref
  117. array-element-type array-rank array-dimension array-dimensions array-total-size
  118. array-in-bounds-p array-row-major-index row-major-aref adjustable-array-p
  119. bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
  120. bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p fill-pointer vector-push
  121. vector-push-extend vector-pop adjust-array char schar string= string-equal
  122. string< string> string<= string>= string/= string-lessp string-greaterp
  123. string-not-greaterp string-not-lessp string-not-equal make-string string-trim
  124. string-left-trim string-right-trim string-upcase string-downcase
  125. string-capitalize nstring-upcase nstring-downcase nstring-capitalize string
  126. eval evalhook applyhook constantp make-synonym-stream make-broadcast-stream
  127. make-concatenated-stream make-two-way-stream make-echo-stream
  128. make-string-input-stream make-string-output-stream get-output-stream-string
  129. streamp open-stream-p input-stream-p output-stream-p stream-element-type close
  130. broadcast-stream-streams concatenated-stream-streams echo-stream-input-stream
  131. echo-stream-output-stream synonym-stream-symbol two-way-stream-input-stream
  132. two-way-stream-output-stream interactive-stream-p
  133. copy-readtable readtablep set-syntax-from-char set-macro-character
  134. get-macro-character make-dispatch-macro-character
  135. set-dispatch-macro-character get-dispatch-macro-character readtable-case
  136. read read-preserving-whitespace read-delimited-list read-line read-char
  137. unread-char peek-char listen read-char-no-hang clear-input read-from-string
  138. parse-integer read-byte write prin1 print pprint princ write-to-string
  139. prin1-to-string princ-to-string write-char write-string write-line terpri
  140. fresh-line finish-output force-output clear-output write-byte format y-or-n-p
  141. yes-or-no-p wild-pathname-p pathname-match-p translate-pathname
  142. #+LOGICAL-PATHNAMES logical-pathname
  143. #+LOGICAL-PATHNAMES translate-logical-pathname
  144. #+LOGICAL-PATHNAMES logical-pathname-translations
  145. #+LOGICAL-PATHNAMES load-logical-pathname-translations
  146. compile-file-pathname pathname truename parse-namestring merge-pathnames
  147. make-pathname pathnamep pathname-host pathname-device pathname-directory
  148. pathname-name pathname-type pathname-version namestring file-namestring
  149. directory-namestring host-namestring enough-namestring user-homedir-pathname
  150. open rename-file delete-file probe-file file-write-date file-author
  151. file-position file-length load directory error cerror warn break compile
  152. compile-file disassemble function-lambda-expression
  153. documentation  variable structure type ; drei Dokumentations-Typen
  154. describe describe-object inspect room ed dribble apropos apropos-list
  155. get-decoded-time get-universal-time decode-universal-time encode-universal-time
  156. get-internal-run-time get-internal-real-time sleep lisp-implementation-type
  157. lisp-implementation-version machine-type machine-version machine-instance
  158. software-type software-version short-site-name long-site-name identity
  159. add-method call-next-method class-name class-of compute-applicable-methods
  160. find-class find-method function-keywords initialize-instance make-instance
  161. method-qualifiers next-method-p no-applicable-method no-next-method
  162. print-object reinitialize-instance remove-method shared-initialize slot-boundp
  163. slot-exists-p slot-makunbound slot-missing slot-unbound slot-value
  164. signal make-condition compute-restarts restart-name find-restart invoke-restart
  165. invoke-restart-interactively abort continue muffle-warning store-value
  166. use-value invoke-debugger simple-condition-format-string
  167. simple-condition-format-arguments type-error-datum type-error-expected-type
  168. package-error-package print-not-readable-object stream-error-stream
  169. file-error-pathname cell-error-name arithmetic-error-operation
  170. arithmetic-error-operands
  171. ;; Special-forms:
  172. eval-when quote function setq progn let let* locally compiler-let progv flet
  173. labels macrolet symbol-macrolet if block return-from tagbody go
  174. multiple-value-call multiple-value-prog1 catch unwind-protect throw declare
  175. the load-time-value
  176. ;; Macros:
  177. deftype defun defvar defparameter defconstant and or psetq setf psetf shiftf
  178. rotatef define-modify-macro defsetf define-setf-method prog1 prog2
  179. when unless cond
  180. case typecase  otherwise ; otherwise als Marker für die catchall-clause
  181. return loop do do* dolist dotimes prog prog* multiple-value-list
  182. multiple-value-bind multiple-value-setq nth-value defmacro destructuring-bind
  183. declaim remf defpackage do-symbols do-external-symbols do-all-symbols incf decf
  184. push pushnew pop with-hash-table-iterator defstruct with-open-stream
  185. with-input-from-string with-output-to-string with-standard-io-syntax
  186. print-unreadable-object with-open-file
  187. check-type assert etypecase ctypecase ecase ccase trace untrace
  188. step time
  189. loop-finish
  190. formatter
  191. defclass defgeneric defmethod generic-flet generic-function generic-labels
  192. with-accessors with-slots
  193. check-type assert etypecase ctypecase ecase ccase handler-case ignore-errors
  194. handler-bind define-condition with-simple-restart restart-case restart-bind
  195. with-condition-restarts
  196. ;; sonstige Markierer:
  197. lambda
  198. ; Lambda-Listen-Markierer:
  199. &optional &rest &key &allow-other-keys &aux &body &whole &environment
  200. ; EVAL-WHEN-Situationen:
  201. eval load compile
  202. ; DECLARE-Specifier:
  203. special type ftype function inline notinline ignore ignorable optimize speed
  204. space safety compilation-speed debug declaration dynamic-extent
  205. ; Methoden-Kombination:
  206. standard
  207. ))
  208.  
  209. ;===============================================================================
  210.  
  211. (in-package "SYSTEM")
  212.  
  213. (defun common-lisp:make-package (package-name &key (nicknames '()) (use '("COMMON-LISP")))
  214.   (lisp:make-package package-name :nicknames nicknames :use use)
  215. )
  216.  
  217. ; impliziten BLOCK in eine Liste von Funktionsdefinitionen einfügen
  218. (defun expand-fundefs (specform fdefs env)
  219.   (let ((new-fundefs '()))
  220.     (loop
  221.       (when (atom fdefs)
  222.         (if (null fdefs)
  223.           (return)
  224.           (error-of-type 'program-error
  225.             #L{
  226.             DEUTSCH "Dotted list im Code von ~S, endet mit ~S"
  227.             ENGLISH "code after ~S contains a dotted list, ending with ~S"
  228.             FRANCAIS "Le code de ~S contient une paire pointée, terminée par ~S"
  229.             }
  230.             specform fdefs
  231.       ) ) )
  232.       (let ((fdef (pop fdefs)))
  233.         (unless (and (consp fdef) (consp (cdr fdef)))
  234.           (error-of-type 'program-error
  235.             #L{
  236.             DEUTSCH "Falsche Syntax einer Funktionsdefinition in ~S: ~S"
  237.             ENGLISH "Illegal function definition syntax in ~S: ~S"
  238.             FRANCAIS "Mauvaise syntaxe de définition de fonction dans ~S : ~S"
  239.             }
  240.             specform fdef
  241.         ) )
  242.         (multiple-value-bind (body-rest declarations docstring)
  243.             (sys::parse-body (cddr fdef) t env)
  244.           (push `(,(first fdef) ,(second fdef)
  245.                   ,@(if declarations `((DECLARE ,@declarations)) '())
  246.                   ,@(if docstring `(,docstring) '())
  247.                   (BLOCK ,(first fdef) ,@body-rest)
  248.                  )
  249.                 new-fundefs
  250.       ) ) )
  251.     )
  252.     (nreverse new-fundefs)
  253. ) )
  254.  
  255. (defmacro common-lisp:flet (fundefs &body body &environment env)
  256.   (multiple-value-bind (body-rest declarations)
  257.       (sys::parse-body body nil env)
  258.     ((lambda (main-form)
  259.        (if declarations
  260.          `(LOCALLY (DECLARE ,@declarations) ,main-form)
  261.          main-form
  262.      ) )
  263.      `(LISP:FLET
  264.         ,(expand-fundefs 'common-lisp:flet fundefs env)
  265.         ,@body-rest
  266.       )
  267. ) ) )
  268.  
  269. (defmacro common-lisp:labels (fundefs &body body &environment env)
  270.   (multiple-value-bind (body-rest declarations)
  271.       (sys::parse-body body nil env)
  272.     ((lambda (main-form)
  273.        (if declarations
  274.          `(LOCALLY (DECLARE ,@declarations) ,main-form)
  275.          main-form
  276.      ) )
  277.      `(LISP:LABELS
  278.         ,(expand-fundefs 'common-lisp:labels fundefs env) ; env stimmt hier nicht ganz
  279.         ,@body-rest
  280.       )
  281. ) ) )
  282.  
  283. (defmacro common-lisp:macrolet (macrodefs &body body &environment env)
  284.   (multiple-value-bind (body-rest declarations)
  285.       (sys::parse-body body nil env)
  286.     `(LISP:MACROLET ,macrodefs
  287.        ,@(if declarations
  288.            `((LOCALLY (DECLARE ,@declarations) ,@body-rest))
  289.            body-rest
  290.          )
  291.      )
  292. ) )
  293.  
  294. ;===============================================================================
  295.  
  296. (defpackage "COMMON-LISP-USER" (:nicknames "CL-USER") (:use "COMMON-LISP"))
  297.  
  298. ;===============================================================================
  299.  
  300.