From 982cfabcbda4f89c46a15e1af92562a0baacbcd1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 20 Aug 2016 15:36:20 +0200 Subject: [PATCH] cleanup: remove obfuscating feature It's 2016 and I doubt that any non-ansi CL still is used in wild *and* depends on Quicklisp CLX. Fixes #51. --- buffer.lisp | 123 ++++++----------------- clx.asd | 2 - clx.lisp | 14 --- defsystem.lisp | 16 +-- dep-allegro.lisp | 64 +----------- dep-lispworks.lisp | 4 +- dep-openmcl.lisp | 2 +- depdefs.lisp | 65 +------------ dependent.lisp | 238 ++------------------------------------------- display.lisp | 6 +- exclMakefile | 3 - input.lisp | 32 +----- macros.lisp | 17 +--- manager.lisp | 31 +----- package.lisp | 210 +-------------------------------------- provide.lisp | 5 - resource.lisp | 8 +- text.lisp | 50 ++-------- 18 files changed, 64 insertions(+), 826 deletions(-) diff --git a/buffer.lisp b/buffer.lisp index c488973..dd71190 100644 --- a/buffer.lisp +++ b/buffer.lisp @@ -68,7 +68,6 @@ ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-buffer-body. () ,@body)) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-buffer-body.)) (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) (let ((buf (if (or (symbolp buffer) (constantp buffer)) @@ -87,13 +86,10 @@ (declare (type display buffer) (type (or null number) timeout) (type function function) - #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: This is probably more a bug in SBCL (logged as ;; bug #243) - (ignorable timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (ignorable timeout)) (with-buffer (buffer :timeout timeout :inline t) (funcall function))) @@ -285,10 +281,7 @@ (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) + (dynamic-extent request-function)) (with-buffer (display :inline t) (multiple-value-prog1 (progn @@ -300,10 +293,7 @@ (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function)) + (dynamic-extent request-function)) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) @@ -321,10 +311,7 @@ (declare (type display display) (type generalized-boolean multiple-reply)) (declare (type function request-function reply-function) - #+clx-ansi-common-lisp - (dynamic-extent request-function reply-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg request-function reply-function)) + (dynamic-extent request-function reply-function)) (let ((pending-command nil) (reply-buffer nil)) (declare (type (or null pending-command) pending-command) @@ -495,11 +482,10 @@ (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,totype) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (if transform (flet ((,ntrans (v) (funcall transform (,transformer v)))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (declare (dynamic-extent #',ntrans)) (,reader reply-buffer result-type nitems #',ntrans data start index)) (,reader reply-buffer result-type nitems #',transformer data start index))))) @@ -526,8 +512,7 @@ (type array-index nitems start index) (type list data) (type (function (,type) t) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-buffer-input (reply-buffer :sizes (,size) :index index) (do* ((j nitems (index- j 1)) (list (nthcdr start data) (cdr list)) @@ -554,10 +539,7 @@ (type array-index nitems start index) (type (simple-array card8 (*)) data)) (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) @@ -587,10 +569,7 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card8) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) @@ -608,8 +587,7 @@ (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,type) t)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (let ((result (or data (make-sequence result-type nitems)))) (typecase result (list @@ -664,10 +642,7 @@ (type array-index nitems start index) (type (simple-array card16 (*)) data)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) @@ -700,10 +675,7 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card16) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) @@ -749,10 +721,7 @@ (type array-index nitems start index) (type (simple-array card32 (*)) data)) (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) @@ -785,10 +754,7 @@ (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card32) t) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) @@ -816,11 +782,10 @@ (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,fromtype)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (if transform (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) - #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) + (declare (dynamic-extent #',ntrans)) (,writer buffer boffset data start end #',ntrans)) (,writer buffer boffset data start end #',transformer))))) @@ -849,8 +814,7 @@ (type list data) (type array-index boffset start end) (type (function (t) ,type) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (writing-buffer-chunks ,type ((list (nthcdr start data))) ((type list list)) @@ -902,10 +866,7 @@ (type (simple-array card8 (*)) data) (type array-index boffset start end)) (declare (type (function (card8) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start)) @@ -936,10 +897,7 @@ (type vector data) (type array-index boffset start end)) (declare (type (function (t) card8) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) @@ -957,8 +915,7 @@ (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,type)) transform) - #+clx-ansi-common-lisp (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) + (dynamic-extent transform)) (typecase data (list (if transform @@ -1017,10 +974,7 @@ (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) @@ -1063,10 +1017,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) @@ -1119,10 +1070,7 @@ (type (simple-array int16 (*)) data) (type array-index boffset start end)) (declare (type (function (int16) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) @@ -1165,10 +1113,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) int16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) @@ -1221,10 +1166,7 @@ (type (simple-array card32 (*)) data) (type array-index boffset start end)) (declare (type (function (card32) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) @@ -1267,10 +1209,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card32) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) @@ -1359,10 +1298,7 @@ (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) @@ -1396,10 +1332,7 @@ (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) - #+clx-ansi-common-lisp - (dynamic-extent transform) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg transform)) + (dynamic-extent transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) diff --git a/clx.asd b/clx.asd index cfa17dc..172f98e 100644 --- a/clx.asd +++ b/clx.asd @@ -23,8 +23,6 @@ (defpackage :clx-system (:use :cl :asdf)) (in-package :clx-system) -(pushnew :clx-ansi-common-lisp *features*) - (defclass clx-source-file (cl-source-file) ()) (defclass xrender-source-file (clx-source-file) ()) diff --git a/clx.lisp b/clx.lisp index ce81f6d..2795556 100644 --- a/clx.lisp +++ b/clx.lisp @@ -159,20 +159,6 @@ (deftype card4 () '(unsigned-byte 4)) -#-clx-ansi-common-lisp -(deftype real (&optional (min '*) (max '*)) - (labels ((convert (limit floatp) - (typecase limit - (number (if floatp (float limit 0s0) (rational limit))) - (list (map 'list #'convert limit)) - (otherwise limit)))) - `(or (float ,(convert min t) ,(convert max t)) - (rational ,(convert min nil) ,(convert max nil))))) - -#-clx-ansi-common-lisp -(deftype base-char () - 'string-char) - ; Note that we are explicitly using a different rgb representation than what ; is actually transmitted in the protocol. diff --git a/defsystem.lisp b/defsystem.lisp index bec62aa..74b5a2c 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -20,7 +20,6 @@ ;;; implied warranty. ;;; #+ features used in this file -;;; clx-ansi-common-lisp ;;; lispm ;;; genera ;;; minima @@ -33,23 +32,15 @@ ;;; CMU ;;; sbcl -#+(or Genera Minima sbcl ecl) -(eval-when (:compile-toplevel :load-toplevel :execute) - (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*)) - -#+(and Genera clx-ansi-common-lisp) +#+Genera (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) -#-(or clx-ansi-common-lisp cmu) -(lisp:in-package :user) - #+cmu (lisp:in-package "XLIB") #+cmu (export 'load-clx) -#+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) @@ -375,7 +366,7 @@ :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) - #+clx-ansi-common-lisp (*compile-verbose* t) + (*compile-verbose* t) (*load-verbose* t)) ;; Make sure source-path and binary-path file types are distinct so @@ -445,9 +436,8 @@ ;; Now compile and load all the files. ;; Defer compiler warnings until everything's compiled, if possible. - (#+(or clx-ansi-common-lisp CMU) with-compilation-unit + (with-compilation-unit #+lcl3.0 lucid::with-deferred-warnings - #-(or lcl3.0 clx-ansi-common-lisp CMU) progn () (compile-and-load "package") diff --git a/dep-allegro.lisp b/dep-allegro.lisp index 3281a27..365d279 100644 --- a/dep-allegro.lisp +++ b/dep-allegro.lisp @@ -863,7 +863,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) #-lispm @@ -874,7 +874,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) @@ -1030,12 +1030,10 @@ (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) -#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) @@ -1058,33 +1056,8 @@ (ext::disable-clx-event-handling disp))) (error condx))) -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (define-condition x-error (error) ()) - ;;----------------------------------------------------------------------------- ;; HOST hacking @@ -1273,38 +1246,6 @@ Returns a list of (host display-number screen protocol)." (setq *temp-gcontext-cache* nil) nil) - - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - ) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE @@ -1321,7 +1262,6 @@ Returns a list of (host display-number screen protocol)." ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) diff --git a/dep-lispworks.lisp b/dep-lispworks.lisp index 91523ef..6adcc5a 100644 --- a/dep-lispworks.lisp +++ b/dep-lispworks.lisp @@ -774,7 +774,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) @@ -784,7 +784,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) diff --git a/dep-openmcl.lisp b/dep-openmcl.lisp index 9da24e2..4585e4c 100644 --- a/dep-openmcl.lisp +++ b/dep-openmcl.lisp @@ -673,7 +673,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) diff --git a/depdefs.lisp b/depdefs.lisp index eb3db9f..0d61d3c 100644 --- a/depdefs.lisp +++ b/depdefs.lisp @@ -35,16 +35,6 @@ (lisp:rational x))) (deftype rational (&optional l u) `(lisp:rational ,l ,u))) -;;; DECLAIM - -#-clx-ansi-common-lisp -(defmacro declaim (&rest decl-specs) - (if (cdr decl-specs) - `(progn - ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) - decl-specs)) - `(proclaim ',(car decl-specs)))) - ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. #-Genera @@ -60,18 +50,6 @@ #-(or lispm lcl3.0) (declaim (declaration arglist)) -;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has -;;; dynamic extent and therefore can be kept on the stack and not copied to -;;; the heap, even though the value is passed out of the function. - -#-(or clx-ansi-common-lisp lcl3.0) -(declaim (declaration dynamic-extent)) - -;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used. - -#-clx-ansi-common-lisp -(declaim (declaration ignorable)) - ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to ;;; indent calls to the function or macro containing the declaration. @@ -419,14 +397,7 @@ used, since NIL is the empty list.") (defmacro def-clx-class ((name &rest options) &body slots) (if (or (not (listp *def-clx-class-use-defclass*)) (member name *def-clx-class-use-defclass*)) - (let ((clos-package #+clx-ansi-common-lisp - (find-package :common-lisp) - #-clx-ansi-common-lisp - (or (find-package :clos) - (find-package :pcl) - (let ((lisp-pkg (find-package :lisp))) - (and (find-symbol (string 'defclass) lisp-pkg) - lisp-pkg)))) + (let ((clos-package (find-package :common-lisp)) (constructor t) (constructor-args t) (include nil) @@ -598,40 +569,6 @@ used, since NIL is the empty list.") ;; Printing routines. ;;----------------------------------------------------------------------------- -#-(or clx-ansi-common-lisp Genera) -(defun print-unreadable-object-function (object stream type identity function) - (declare #+lispm - (sys:downward-funarg function)) - (princ "#<" stream) - (when type - (let ((type (type-of object)) - (pcl-package (find-package :pcl))) - ;; Handle pcl type-of lossage - (when (and pcl-package - (symbolp type) - (eq (symbol-package type) pcl-package) - (string-equal (symbol-name type) "STD-INSTANCE")) - (setq type - (funcall (intern (symbol-name 'class-name) pcl-package) - (funcall (intern (symbol-name 'class-of) pcl-package) - object)))) - (prin1 type stream))) - (when (and type function) (princ " " stream)) - (when function (funcall function)) - (when (and (or type function) identity) (princ " " stream)) - (when identity (princ "???" stream)) - (princ ">" stream) - nil) - -#-(or clx-ansi-common-lisp Genera) -(defmacro print-unreadable-object - ((object stream &key type identity) &body body) - (if body - `(flet ((.print-unreadable-object-body. () ,@body)) - (print-unreadable-object-function - ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) - `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) - ;;----------------------------------------------------------------------------- ;; Image stuff diff --git a/dependent.lisp b/dependent.lisp index 1516773..c63af8e 100644 --- a/dependent.lisp +++ b/dependent.lisp @@ -1130,19 +1130,13 @@ #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (apply #'process:block-process whostate predicate predicate-args)) #+(and lispm (not Genera)) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #-clx-ansi-common-lisp - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (apply #'global:process-wait whostate predicate predicate-args)) #+excl @@ -2088,7 +2082,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) #-lispm @@ -2099,7 +2093,7 @@ ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) - #+clx-ansi-common-lisp (dynamic-extent ,var)) + (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) @@ -2344,31 +2338,10 @@ (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (apply #'sys:signal condition keyargs)) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (sys:signal (apply #'zl:make-condition condition keyargs) - :proceed-types proceed-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-error (condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition keyargs)) - -#+(and Genera (not clx-ansi-common-lisp)) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (declare (dbg:error-reporter)) - (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) - -#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) -#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) @@ -2391,175 +2364,8 @@ (ext::disable-clx-event-handling disp))) (error condx))) -#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-error (condition &rest keyargs) - (error "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun x-cerror (proceed-format-string condition &rest keyargs) - (cerror proceed-format-string "X-Error: ~a" - (princ-to-string (apply #'make-condition condition keyargs)))) - -;; version 15 of Pitman error handling defines the syntax for define-condition to be: -;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] -;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) -;; or (:report exp) - -#+lcl3.0 -(defmacro define-condition (name parent-types &optional slots &rest args) - `(lcl:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and excl (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(excl::define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and CMU (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &optional slots &rest args) - `(common-lisp:define-condition - ,name (,(first parent-types)) - ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - slots) - ,@args)) - -#+(and lispm (not clx-ansi-common-lisp)) -(defmacro define-condition (name parent-types &body options) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil)) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - `(within-definition (,name define-condition) - (zl:defflavor ,name ,slot-names ,parent-types - :initable-instance-variables - #-Genera - (:accessor-prefix ,conc-name) - #+Genera - (:conc-name ,conc-name) - #-Genera - (:outside-accessible-instance-variables ,@slot-names) - #+Genera - (:readable-instance-variables ,@slot-names)) - ,(when reporter ;; when no reporter, parent's is inherited - `(zl:defmethod #-Genera (,name :report) - #+Genera (dbg:report ,name) (stream) - ,(if (stringp reporter) - `(write-string ,reporter stream) - `(,reporter global:self stream)) - global:self)) - (zl:compile-flavor-methods ,name) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ',name))) - -#+(and lispm (not Genera) (not clx-ansi-common-lisp)) -(zl:defflavor x-error () (global:error)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defflavor x-error - ((dbg:proceed-types '(:continue)) ; - continue-format-string) - (sys:error) - (:initable-instance-variables continue-format-string)) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (scl:make-instance x-error) (&rest ignore) - (when (not (sys:variable-boundp continue-format-string)) - (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) - -#+(and Genera (not clx-ansi-common-lisp)) -(scl:defmethod (dbg:proceed x-error :continue) () - :continue) - -#+(and Genera (not clx-ansi-common-lisp)) -(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) - (format stream continue-format-string)) - -#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (define-condition x-error (error) ()) -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defstruct x-error - report-function) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) -(defmacro define-condition (name parent-types &body options) - ;; Define a structure that when printed displays an error message - (flet ((reporter-for-condition (name) - (xintern "." name '-reporter.))) - (let ((slot-names - (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) - (pop options))) - (documentation nil) - (conc-name (concatenate 'string (string name) "-")) - (reporter nil) - (condition (gensym)) - (stream (gensym)) - (report-function (reporter-for-condition name))) - (dolist (item options) - (ecase (first item) - (:documentation (setq documentation (second item))) - (:conc-name (setq conc-name (string (second item)))) - (:report (setq reporter (second item))))) - (unless reporter - (setq report-function (reporter-for-condition (first parent-types)))) - `(within-definition (,name define-condition) - (defstruct (,name (:conc-name ,(intern conc-name)) - (:print-function condition-print) - (:include ,(first parent-types) - (report-function ',report-function))) - ,@slot-names) - ,(when documentation - `(setf (documentation name 'type) ,documentation)) - ,(when reporter - `(defun ,report-function (,condition ,stream) - ,(if (stringp reporter) - `(write-string ,reporter ,stream) - `(,reporter ,condition ,stream)) - ,condition)) - ',name)))) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun condition-print (condition stream depth) - (declare (type x-error condition) - (type stream stream) - (ignore depth)) - (if *print-escape* - (print-unreadable-object (condition stream :type t)) - (funcall (x-error-report-function condition) condition stream)) - condition) - -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(defun make-condition (type &rest slot-initializations) - (declare (dynamic-extent slot-initializations)) - (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) - (symbol-package type)))) - (apply make-function slot-initializations))) - -#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) -(define-condition type-error (x-error) - ((datum :reader type-error-datum :initarg :datum) - (expected-type :reader type-error-expected-type :initarg :expected-type)) - (:report - (lambda (condition stream) - (format stream "~s isn't a ~a" - (type-error-datum condition) - (type-error-expected-type condition))))) - ;;----------------------------------------------------------------------------- ;; HOST hacking @@ -2993,38 +2799,6 @@ Returns a list of (host display-number screen protocol)." (si:define-gc-cleanup clx-cleanup ("CLX Cleanup") (gc-cleanup)) - -;;----------------------------------------------------------------------------- -;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) -;;----------------------------------------------------------------------------- - -#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) -(defun with-standard-io-syntax-function (function) - (declare #+lispm - (sys:downward-funarg function)) - (let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-suppress* nil) - #+ticl (ticl:*print-structure* t) - #+lucid (lucid::*print-structure* t)) - (funcall function))) - -#-(or clx-ansi-common-lisp Genera CMU sbcl ecl) -(defmacro with-standard-io-syntax (&body body) - `(flet ((.with-standard-io-syntax-body. () ,@body)) - (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) - ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE @@ -3041,7 +2815,7 @@ Returns a list of (host display-number screen protocol)." ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. -#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) +#+lispm (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) @@ -3064,7 +2838,7 @@ Returns a list of (host display-number screen protocol)." (setf (char-bit object :hyper) 1))) object) -#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) +#-lispm (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) diff --git a/display.lisp b/display.lisp index 4247cd7..b96357d 100644 --- a/display.lisp +++ b/display.lisp @@ -324,7 +324,6 @@ ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-event-queue-body. () ,@body)) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-event-queue-body.)) (with-event-queue-function ,display ,timeout #'.with-event-queue-body.)) @@ -340,12 +339,9 @@ (declare (type display display) (type (or null number) timeout) (type function function) - #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: see SBCL bug #243 - (ignorable display timeout) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (ignorable display timeout)) (with-event-queue (display :timeout timeout :inline t) (funcall function))) diff --git a/exclMakefile b/exclMakefile index bd0c936..a17f02b 100644 --- a/exclMakefile +++ b/exclMakefile @@ -88,7 +88,6 @@ compile-no-clos-CLX: $(C_OBJS) $(ECHO) " \ (set-case-mode :case-sensitive-lower) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ #+allegro (compile-system :clx) \ #-allegro (compile-clx) \ @@ -107,7 +106,6 @@ compile-partial-clos-CLX: $(C_OBJS) (provide :pcl) \ (gc) (gc) \ (setf (sys:gsgc-parameter :generation-spread) spread))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ (load \"package\") \ (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ @@ -128,7 +126,6 @@ compile-full-clos-CLX: $(C_OBJS) (provide :pcl) \ (gc) (gc) \ (setf (sys:gsgc-parameter :generation-spread) spread))) \ - #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ (load \"package\") \ (setq xlib::*def-clx-class-use-defclass* t) \ diff --git a/input.lisp b/input.lisp index 3719c5b..50a448d 100644 --- a/input.lisp +++ b/input.lisp @@ -388,10 +388,7 @@ (type generalized-boolean force-output-p) (dynamic-extent predicate-args)) (declare (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (let ((reply-buffer nil) (token (or (current-process) (cons nil nil)))) (declare (type (or null reply-buffer) reply-buffer)) @@ -419,10 +416,7 @@ (declare (type display display) (dynamic-extent predicate-args) (type function predicate) - #+clx-ansi-common-lisp - (dynamic-extent predicate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg predicate)) + (dynamic-extent predicate)) (or (apply predicate predicate-args) (null (display-input-in-progress display)) (not (null (display-dead display))))) @@ -763,10 +757,7 @@ (declare (type display display) (type reply-buffer event)) (declare (type function handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg handler)) + (dynamic-extent handler)) (reading-event (event :display display :sizes (8 16 ,@get-sizes)) (funcall handler :display display @@ -1177,10 +1168,7 @@ (type (or null number) timeout) (type generalized-boolean peek-p discard-p force-output-p)) (declare (type t handler) - #+clx-ansi-common-lisp - (dynamic-extent handler) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera handler)) + (dynamic-extent handler)) (event-loop (display event timeout force-output-p discard-p) (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT (event-decoder (and (index< event-code (length *event-handler-vector*)) @@ -1533,17 +1521,6 @@ (when (= code (second extension)) (return (first extension)))))) -#-(or clx-ansi-common-lisp excl lcl3.0 CMU) -(define-condition request-error (x-error) - ((display :reader request-error-display) - (error-key :reader request-error-error-key) - (major :reader request-error-major) - (minor :reader request-error-minor) - (sequence :reader request-error-sequence) - (current-sequence :reader request-error-current-sequence) - (asynchronous :reader request-error-asynchronous)) - (:report report-request-error)) - (defun report-request-error (condition stream) (let ((error-key (request-error-error-key condition)) (asynchronous (request-error-asynchronous condition)) @@ -1558,7 +1535,6 @@ ;; Since the :report arg is evaluated as (function report-request-error) the ;; define-condition must come after the function definition. -#+(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) ((display :reader request-error-display :initarg :display) (error-key :reader request-error-error-key :initarg :error-key) diff --git a/macros.lisp b/macros.lisp index 24e1c40..84d45e1 100644 --- a/macros.lisp +++ b/macros.lisp @@ -544,10 +544,7 @@ (defun mask-get (index type-values body-function) (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + (dynamic-extent body-function)) ;; This is a function, because it must return more than one form (called by get-put-items) ;; Functions that use this must have a binding for %MASK (let* ((bit 0) @@ -578,10 +575,7 @@ (defun mask-put (index type-values body-function) (declare (type function body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + (dynamic-extent body-function)) ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES ;; A 32 bit value follows for each non-nil value. `((let ((%mask 0) @@ -639,10 +633,7 @@ (defun get-put-items (index type-args putp &optional body-function) (declare (type (or null function) body-function) - #+clx-ansi-common-lisp - (dynamic-extent body-function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg body-function)) + (dynamic-extent body-function)) ;; Given a lists of the form (type item item ... item) ;; Calls body-function with four arguments, a function name, ;; index, item name, and optional arguments. @@ -712,7 +703,6 @@ (declare (type display .display.)) (with-buffer-request-internal (.display. ,opcode ,@options) ,@type-args))) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body.)) (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) 'with-buffer-request-function-nolock @@ -752,7 +742,6 @@ (type reply-buffer .reply-buffer.)) (progn .display. .reply-buffer. nil) ,reply-body)) - #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body. #'.reply-body.)) (with-buffer-request-and-reply-function ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) diff --git a/manager.lisp b/manager.lisp index 0fa86e2..1a771bb 100644 --- a/manager.lisp +++ b/manager.lisp @@ -731,36 +731,7 @@ (get-property root property :type type :result-type result-type :start start :end end :transform transform))) -;; Implement the following: -;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) -;; (transform #'char->card8) (start 0) end) (data) -;; In order to avoid having to pass positional parameters to set-cut-buffer, -;; We've got to do the following. WHAT A PAIN... -#-clx-ansi-common-lisp -(define-setf-method cut-buffer (display &rest option-list) - (declare (dynamic-extent option-list)) - (do* ((options (copy-list option-list)) - (option options (cddr option)) - (store (gensym)) - (dtemp (gensym)) - (temps (list dtemp)) - (values (list display))) - ((endp option) - (values (nreverse temps) - (nreverse values) - (list store) - `(set-cut-buffer ,store ,dtemp ,@options) - `(cut-buffer ,@options))) - (unless (member (car option) '(:buffer :type :format :start :end :transform)) - (error "Keyword arg ~s isn't recognized" (car option))) - (let ((x (gensym))) - (push x temps) - (push (cadr option) values) - (setf (cadr option) x)))) - -(defun - #+clx-ansi-common-lisp (setf cut-buffer) - #-clx-ansi-common-lisp set-cut-buffer +(defun (setf cut-buffer) (data display &key (buffer 0) (type :STRING) (format 8) (start 0) end (transform #'char->card8)) (declare (type sequence data) diff --git a/package.lisp b/package.lisp index a58d693..0d642e5 100644 --- a/package.lisp +++ b/package.lisp @@ -11,223 +11,15 @@ ;;; publicity pertaining to distribution of the software without specific, ;;; written prior permission. -;;; The CLtL way - -#-clx-ansi-common-lisp -(lisp:in-package :xlib :use '(:lisp)) - -#+(and (or kcl ibcl) (not clx-ansi-common-lisp)) -(shadow - '( - rational - )) - -#+(and CMU (not clx-ansi-common-lisp)) -(shadow '(define-condition)) - -#+(and lispm (not clx-ansi-common-lisp)) -(import - '( - sys:arglist - sys:with-stack-list - sys:with-stack-list* - )) - -#+(and Genera (not clx-ansi-common-lisp)) -(import - '( - future-common-lisp:print-unreadable-object - future-common-lisp:with-standard-io-syntax - zwei:indentation - )) - -#+(and lcl3.0 (not clx-ansi-common-lisp)) -(import - '( - lcl:arglist - lcl:dynamic-extent - lcl:type-error - lucid::type-error-datum - lucid::type-error-expected-type - )) - -#+(and excl (not clx-ansi-common-lisp)) -(import - '( - excl::arglist - excl::dynamic-extent - excl::type-error - excl::type-error-datum - excl::type-error-expected-type - )) - -#+(and allegro (not clx-ansi-common-lisp)) -(import - '( - excl::without-interrupts - )) - -#-clx-ansi-common-lisp -(export - '( - *version* access-control access-error access-hosts - activate-screen-saver add-access-host add-resource add-to-save-set - alist alloc-color alloc-color-cells alloc-color-planes alloc-error - allow-events angle arc-seq array-index atom-error atom-name - bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p - bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image - boole-constant boolean card16 card29 card32 card8 - card8->char change-active-pointer-grab change-keyboard-control - change-keyboard-mapping change-pointer-control change-property - char->card8 char-ascent char-attributes char-descent - char-left-bearing char-right-bearing char-width character->keysyms - character-in-map-p circulate-window-down circulate-window-up clear-area - close-display close-down-mode close-font closed-display color - color-blue color-green color-p color-red color-rgb colormap - colormap-display colormap-equal colormap-error colormap-id colormap-p - colormap-plist colormap-visual-info connection-failure convert-selection - copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components - copy-image copy-plane create-colormap create-cursor - create-gcontext create-glyph-cursor create-image create-pixmap - create-window cursor cursor-display cursor-equal cursor-error - cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error - default-error-handler default-keysym-index default-keysym-translate - define-error define-extension define-gcontext-accessor - define-keysym define-keysym-set delete-property delete-resource - destroy-subwindows destroy-window device-busy device-event-mask - device-event-mask-class discard-current-event discard-font-info display - display-after-function display-authorization-data display-authorization-name - display-bitmap-format display-byte-order display-default-screen - display-display display-error-handler - display-extended-max-request-length display-finish-output - display-force-output display-host display-image-lsb-first-p - display-invoke-after-function display-keycode-range display-max-keycode - display-max-request-length display-min-keycode display-motion-buffer-size - display-nscreens display-p display-pixmap-formats display-plist - display-protocol-major-version display-protocol-minor-version - display-protocol-version display-release-number - display-report-asynchronous-errors display-resource-id-base - display-resource-id-mask display-roots display-vendor - display-vendor-name display-xdefaults display-xid draw-arc - draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph - draw-image-glyphs draw-line draw-lines draw-point draw-points - draw-rectangle draw-rectangles draw-segments drawable - drawable-border-width drawable-depth drawable-display drawable-equal - drawable-error drawable-height drawable-id drawable-p - drawable-plist drawable-root drawable-width drawable-x drawable-y - error-key event-case event-cond event-handler event-key - event-listen event-mask event-mask-class extension-opcode - find-atom font font-all-chars-exist-p font-ascent - font-default-char font-descent font-direction font-display - font-equal font-error font-id font-max-byte1 font-max-byte2 - font-max-char font-min-byte1 font-min-byte2 font-min-char - font-name font-p font-path font-plist font-properties - font-property fontable force-gcontext-changes free-colormap - free-colors free-cursor free-gcontext free-pixmap gcontext - gcontext-arc-mode gcontext-background - gcontext-cache-p gcontext-cap-style - gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x - gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display - gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule - gcontext-fill-style gcontext-font gcontext-foreground gcontext-function - gcontext-id gcontext-join-style gcontext-key gcontext-line-style - gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist - gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x - gcontext-ts-y generalized-boolean get-external-event-code get-image get-property - get-raw-image get-resource get-search-resource get-search-table - get-standard-colormap get-wm-class global-pointer-position grab-button - grab-key grab-keyboard grab-pointer grab-server grab-status - icon-sizes iconify-window id-choice-error illegal-request-error - image image-blue-mask image-depth image-green-mask image-height - image-name image-pixmap image-plist image-red-mask image-width - image-x image-x-hot image-x-p image-xy image-xy-bitmap-list - image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p - image-z-pixarray implementation-error input-focus install-colormap - installed-colormaps int16 int32 int8 intern-atom invalid-font - keyboard-control keyboard-mapping keycode->character keycode->keysym - keysym keysym->character keysym->keycodes keysym-in-map-p - keysym-set kill-client kill-temporary-clients length-error - list-extensions list-font-names list-fonts list-properties - lookup-color lookup-error make-color make-event-handlers - make-event-keys make-event-mask make-resource-database make-state-keys - make-state-mask make-wm-hints make-wm-size-hints map-resource - map-subwindows map-window mapping-notify mask16 mask32 - match-error max-char-ascent max-char-attributes max-char-descent - max-char-left-bearing max-char-right-bearing max-char-width - merge-resources min-char-ascent min-char-attributes min-char-descent - min-char-left-bearing min-char-right-bearing min-char-width - missing-parameter modifier-key modifier-mapping modifier-mask - motion-events name-error no-operation open-display open-font - pixarray pixel pixmap pixmap-display pixmap-equal - pixmap-error pixmap-format pixmap-format-bits-per-pixel - pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad - pixmap-id pixmap-p pixmap-plist point-seq pointer-control - pointer-event-mask pointer-event-mask-class pointer-mapping - pointer-position process-event put-image put-raw-image - query-best-cursor query-best-stipple query-best-tile query-colors - query-extension query-keymap query-pointer query-tree queue-event - read-bitmap-file read-resources recolor-cursor rect-seq - remove-access-host remove-from-save-set reparent-window repeat-seq - reply-length-error reply-timeout request-error reset-screen-saver - resource-database resource-database-timestamp resource-error - resource-id resource-key rgb-colormaps rgb-val root-resources - rotate-cut-buffers rotate-properties screen screen-backing-stores - screen-black-pixel screen-default-colormap screen-depths - screen-event-mask-at-open screen-height screen-height-in-millimeters - screen-max-installed-maps screen-min-installed-maps screen-p - screen-plist screen-root screen-root-depth screen-root-visual - screen-root-visual-info screen-save-unders-p screen-saver - screen-white-pixel screen-width screen-width-in-millimeters seg-seq - selection-owner send-event sequence-error set-access-control - set-close-down-mode set-input-focus set-modifier-mapping - set-pointer-mapping set-screen-saver set-selection-owner - set-standard-colormap set-standard-properties set-wm-class - set-wm-properties set-wm-resources state-keysym-p state-mask-key - store-color store-colors stringable text-extents text-width - timestamp transient-for translate-coordinates translate-default - translation-function type-error undefine-keysym unexpected-reply - ungrab-button ungrab-key ungrab-keyboard ungrab-pointer - ungrab-server uninstall-colormap unknown-error unmap-subwindows - unmap-window value-error visual-info visual-info-bits-per-rgb - visual-info-blue-mask visual-info-class visual-info-colormap-entries - visual-info-display visual-info-green-mask visual-info-id visual-info-p - visual-info-plist visual-info-red-mask warp-pointer - warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside - win-gravity window window-all-event-masks window-background - window-backing-pixel window-backing-planes window-backing-store - window-bit-gravity window-border window-class window-colormap - window-colormap-installed-p window-cursor window-display - window-do-not-propagate-mask window-equal window-error - window-event-mask window-gravity window-id window-map-state - window-override-redirect window-p window-plist window-priority - window-save-under window-visual window-visual-info with-display - with-event-queue with-gcontext with-server-grabbed with-state - withdraw-window wm-client-machine wm-colormap-windows wm-command - wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap - wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y - wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group - wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources - wm-size-hints wm-size-hints-base-height wm-size-hints-base-width - wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect - wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect - wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p - wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p - wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity - wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file - write-resources xatom - )) - ;;; The ANSI Common Lisp way -#+(and Genera clx-ansi-common-lisp) +#+genera (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) -#+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) -#+clx-ansi-common-lisp (defpackage #:xlib (:use common-lisp) (:size 3000) diff --git a/provide.lisp b/provide.lisp index bf6f3c7..4109482 100644 --- a/provide.lisp +++ b/provide.lisp @@ -14,13 +14,8 @@ ;;; (require :clx ) ;;; -#-clx-ansi-common-lisp -(in-package :user) - -#+clx-ansi-common-lisp (in-package :common-lisp-user) -#-clx-ansi-common-lisp (provide :clx) (defvar *clx-source-pathname* diff --git a/resource.lisp b/resource.lisp index 7526868..980e22a 100644 --- a/resource.lisp +++ b/resource.lisp @@ -406,20 +406,14 @@ ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) (type (function (list t &rest t) t) function) - #+clx-ansi-common-lisp (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function) (dynamic-extent args)) (declare (clx-values nil)) (labels ((map-resource-internal (database function args name) (declare (type resource-database database) (type (function (list t &rest t) t) function) (type list name) - #+clx-ansi-common-lisp - (dynamic-extent function) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg function)) + (dynamic-extent function)) (let ((tight (resource-database-tight database)) (loose (resource-database-loose database))) (declare (type list tight loose)) diff --git a/text.lisp b/text.lisp index 08c9973..dcac272 100644 --- a/text.lisp +++ b/text.lisp @@ -114,10 +114,7 @@ (declare (type sequence sequence) (type (or font gcontext) font)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values width ascent descent left right font-ascent font-descent direction (or null array-index))) @@ -221,10 +218,7 @@ (type array-index start) (type (or null array-index) end)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values integer (or null integer))) (when (type? font 'gcontext) (force-gcontext-changes font) @@ -465,10 +459,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) @@ -516,10 +507,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (unless end (setq end (length sequence))) (ecase size @@ -540,10 +528,7 @@ (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) @@ -642,10 +627,7 @@ (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) @@ -744,10 +726,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) @@ -800,10 +779,7 @@ (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg #+Genera * #-Genera translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (setf end (index-min (index+ start 255) (or end (length sequence)))) (ecase size @@ -828,10 +804,7 @@ (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) @@ -893,10 +866,7 @@ (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) - #+clx-ansi-common-lisp - (dynamic-extent translate) - #+(and lispm (not clx-ansi-common-lisp)) - (sys:downward-funarg translate)) + (dynamic-extent translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start))