src/code/host-alieneval.lisp

   1 ;;;; the part of the Alien implementation which is needed at
   2 ;;;; cross-compilation time
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!ALIEN")
  14
  15 (/show0 "host-alieneval.lisp 15")
  16 \f
  17 ;;;; utility functions
  18
  19 (defun align-offset (offset alignment)
  20   (let ((extra (rem offset alignment)))
  21     (if (zerop extra) offset (+ offset (- alignment extra)))))
  22
  23 (defun guess-alignment (bits)
  24   (cond ((null bits) nil)
  25         #!-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64)
  26         ((> bits 16) 32)
  27         ((> bits 8) 16)
  28         ((> bits 1) 8)
  29         (t 1)))
  30 \f
  31 ;;;; ALIEN-TYPE-INFO stuff
  32
  33 ;;; We define a keyword "BOA" constructor so that we can reference the
  34 ;;; slot names in init forms.
  35 (defmacro define-alien-type-class ((name &key include include-args) &rest slots)
  36   (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
  37     (multiple-value-bind (include include-defstruct overrides)
  38         (etypecase include
  39           (null
  40            (values nil 'alien-type nil))
  41           (symbol
  42            (values
  43             include
  44             (alien-type-class-defstruct-name
  45              (alien-type-class-or-lose include))
  46             nil))
  47           (list
  48            (values
  49             (car include)
  50             (alien-type-class-defstruct-name
  51              (alien-type-class-or-lose (car include)))
  52             (cdr include))))
  53       `(progn
  54          (eval-when (:compile-toplevel :load-toplevel :execute)
  55            (create-alien-type-class-if-necessary ',name ',defstruct-name
  56                                                  ',(or include 'root)))
  57          (def!struct (,defstruct-name
  58                         (:include ,include-defstruct
  59                                   (class ',name)
  60                                   ,@overrides)
  61                         (:constructor
  62                          ,(symbolicate "MAKE-" defstruct-name)
  63                          (&key class bits alignment
  64                                ,@(mapcar (lambda (x)
  65                                            (if (atom x) x (car x)))
  66                                          slots)
  67                                ,@include-args
  68                                ;; KLUDGE
  69                                &aux (alignment (or alignment (guess-alignment bits))))))
  70            ,@slots)))))
  71
  72 (defmacro define-alien-type-method ((class method) lambda-list &rest body)
  73   (let ((defun-name (symbolicate class "-" method "-METHOD")))
  74     `(progn
  75        (defun ,defun-name ,lambda-list
  76          ,@body)
  77        (setf (,(method-slot method) (alien-type-class-or-lose ',class))
  78              #',defun-name))))
  79 \f
  80 ;;;; type parsing and unparsing
  81
  82 ;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and
  83 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
  84 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
  85 ;;; a similar effect.
  86 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  87   (defun auxiliary-type-definitions (env)
  88     (multiple-value-bind (result expanded-p)
  89         (%macroexpand '&auxiliary-type-definitions& env)
  90       (if expanded-p
  91           result
  92           ;; This is like having the global symbol-macro definition be
  93           ;; NIL, but global symbol-macros make me vaguely queasy, so
  94           ;; I do it this way instead.
  95           nil))))
  96
  97 ;;; Parse TYPE as an alien type specifier and return the resultant
  98 ;;; ALIEN-TYPE structure.
  99 (defun parse-alien-type (type env)
 100   (declare (type sb!kernel:lexenv-designator env))
 101   (if (consp type)
 102       (let ((translator (info :alien-type :translator (car type))))
 103         (unless translator
 104           (error "unknown alien type: ~/sb!impl:print-type-specifier/"
 105                  type))
 106         (funcall translator type env))
 107       (ecase (info :alien-type :kind type)
 108         (:primitive
 109          (let ((translator (info :alien-type :translator type)))
 110            (unless translator
 111              (error "no translator for primitive alien type ~
 112                       ~/sb!impl:print-type-specifier/"
 113                     type))
 114            (funcall translator (list type) env)))
 115         (:defined
 116          (or (info :alien-type :definition type)
 117              (error "no definition for alien type ~/sb!impl:print-type-specifier/"
 118                     type)))
 119         (:unknown
 120          (error "unknown alien type: ~/sb!impl:print-type-specifier/"
 121                 type)))))
 122
 123 (defun auxiliary-alien-type (kind name env)
 124   (declare (type sb!kernel:lexenv-designator env))
 125   (flet ((aux-defn-matches (x)
 126            (and (eq (first x) kind) (eq (second x) name))))
 127     (let ((in-auxiliaries
 128            (or (find-if #'aux-defn-matches *new-auxiliary-types*)
 129                (find-if #'aux-defn-matches (auxiliary-type-definitions env)))))
 130       (if in-auxiliaries
 131           (values (third in-auxiliaries) t)
 132           (info :alien-type kind name)))))
 133
 134 (defun (setf auxiliary-alien-type) (new-value kind name env)
 135   (declare (type sb!kernel:lexenv-designator env))
 136   (flet ((aux-defn-matches (x)
 137            (and (eq (first x) kind) (eq (second x) name))))
 138     (when (find-if #'aux-defn-matches *new-auxiliary-types*)
 139       (error "attempt to multiply define ~A ~S" kind name))
 140     (when (find-if #'aux-defn-matches (auxiliary-type-definitions env))
 141       (error "attempt to shadow definition of ~A ~S" kind name)))
 142   (push (list kind name new-value) *new-auxiliary-types*)
 143   new-value)
 144
 145 (defun verify-local-auxiliaries-okay ()
 146   (dolist (info *new-auxiliary-types*)
 147     (destructuring-bind (kind name defn) info
 148       (declare (ignore defn))
 149       (when (info :alien-type kind name)
 150         (error "attempt to shadow definition of ~A ~S" kind name)))))
 151
 152 (defun unparse-alien-type (type)
 153   #!+sb-doc
 154   "Convert the alien-type structure TYPE back into a list specification of
 155    the type."
 156   (declare (type alien-type type))
 157   (let ((*record-types-already-unparsed* nil))
 158     (%unparse-alien-type type)))
 159
 160 ;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we
 161 ;;; need to recurse inside the binding of
 162 ;;; *RECORD-TYPES-ALREADY-UNPARSED*.
 163 (defun %unparse-alien-type (type)
 164   (invoke-alien-type-method :unparse type))
 165 \f
 166 ;;;; alien type defining stuff
 167
 168 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 169   (defun %define-alien-type-translator (name translator)
 170     (setf (info :alien-type :kind name) :primitive)
 171     (setf (info :alien-type :translator name) translator)
 172     (clear-info :alien-type :definition name)
 173     name))
 174
 175 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 176   (defun %def-auxiliary-alien-types (types source-location)
 177     (dolist (info types)
 178       ;; Clear up the type we're about to define from the toplevel
 179       ;; *new-auxiliary-types* (local scopes take care of themselves).
 180       ;; Unless this is done we never actually get back the full type
 181       ;; from INFO, since the *new-auxiliary-types* have precendence.
 182       (setf *new-auxiliary-types*
 183             (remove info *new-auxiliary-types*
 184                     :test (lambda (a b)
 185                             (and (eq (first a) (first b))
 186                                  (eq (second a) (second b))))))
 187       (destructuring-bind (kind name defn) info
 188         (let ((old (info :alien-type kind name)))
 189           (unless (or (null old) (alien-type-= old defn))
 190             (warn "redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
 191                   kind name defn old)))
 192         (setf (info :alien-type kind name) defn
 193               (info :source-location :alien-type name) source-location))))
 194
 195   (defun %define-alien-type (name new)
 196     (ecase (info :alien-type :kind name)
 197       (:primitive
 198        (error "~/sb!impl:print-type-specifier/ is a built-in alien type."
 199               name))
 200       (:defined
 201        (let ((old (info :alien-type :definition name)))
 202          (unless (or (null old) (alien-type-= new old))
 203            (warn "redefining ~S to be:~% ~
 204                    ~/sb!impl:print-type-specifier/,~%was~% ~
 205                    ~/sb!impl:print-type-specifier/"
 206                  name
 207                  (unparse-alien-type new)
 208                  (unparse-alien-type old)))))
 209       (:unknown))
 210     (setf (info :alien-type :definition name) new)
 211     (setf (info :alien-type :kind name) :defined)
 212     name))
 213 \f
 214 ;;;; the root alien type
 215
 216 (eval-when (:compile-toplevel :load-toplevel :execute)
 217   (create-alien-type-class-if-necessary 'root 'alien-type nil))
 218
 219 (defmethod print-object ((type alien-type) stream)
 220   (print-unreadable-object (type stream :type t)
 221     (sb!ext:print-type-specifier stream (unparse-alien-type type))))
 222 \f
 223 ;;;; the SAP type
 224
 225 (define-alien-type-class (system-area-pointer))
 226
 227 (define-alien-type-translator system-area-pointer ()
 228   (make-alien-system-area-pointer-type
 229    :bits sb!vm:n-machine-word-bits))
 230
 231 (define-alien-type-method (system-area-pointer :unparse) (type)
 232   (declare (ignore type))
 233   'system-area-pointer)
 234
 235 (define-alien-type-method (system-area-pointer :lisp-rep) (type)
 236   (declare (ignore type))
 237   'system-area-pointer)
 238
 239 (define-alien-type-method (system-area-pointer :alien-rep) (type context)
 240   (declare (ignore type context))
 241   'system-area-pointer)
 242
 243 (define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
 244   (declare (ignore type))
 245   alien)
 246
 247 (define-alien-type-method (system-area-pointer :deport-gen) (type object)
 248   (declare (ignore type))
 249   (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object)
 250   object)
 251
 252 (define-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
 253   (declare (ignore type))
 254   `(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits)))
 255 \f
 256 ;;;; the ALIEN-VALUE type
 257
 258 (define-alien-type-class (alien-value :include system-area-pointer))
 259
 260 (define-alien-type-method (alien-value :lisp-rep) (type)
 261   (declare (ignore type))
 262   nil)
 263
 264 (define-alien-type-method (alien-value :naturalize-gen) (type alien)
 265   `(%sap-alien ,alien ',type))
 266
 267 (define-alien-type-method (alien-value :deport-gen) (type value)
 268   (declare (ignore type))
 269   (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value)
 270   `(alien-sap ,value))
 271 \f
 272 ;;; HEAP-ALIEN-INFO -- defstruct.
 273 ;;;
 274 (defmethod print-object ((info heap-alien-info) stream)
 275   (print-unreadable-object (info stream :type t)
 276     (funcall (formatter "~S ~S~@[ (data)~]")
 277              stream
 278              (heap-alien-info-alien-name info)
 279              (unparse-alien-type (heap-alien-info-type info))
 280              (heap-alien-info-datap info))))
 281
 282 ;;; The form to evaluate to produce the SAP pointing to where in the heap
 283 ;;; it is.
 284 (defun heap-alien-info-sap-form (info)
 285   `(foreign-symbol-sap ,(heap-alien-info-alien-name info)
 286                        ,(heap-alien-info-datap info)))
 287
 288 #-sb-xc-host ; No FOREIGN-SYMBOL-SAP
 289 (defun heap-alien-info-sap (info)
 290   (foreign-symbol-sap (heap-alien-info-alien-name info)
 291                       (heap-alien-info-datap info)))
 292 \f
 293 ;;;; Interfaces to the different methods
 294
 295 (defun alien-type-= (type1 type2)
 296   #!+sb-doc
 297   "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
 298   (or (eq type1 type2)
 299       (and (eq (alien-type-class type1)
 300                (alien-type-class type2))
 301            (invoke-alien-type-method :type= type1 type2))))
 302
 303 (defun alien-subtype-p (type1 type2)
 304   #!+sb-doc
 305   "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the
 306    only supported subtype relationships are is that any pointer type is a
 307    subtype of (* t), and any array type first dimension will match
 308    (array <eltype> nil ...). Otherwise, the two types have to be
 309    ALIEN-TYPE-=."
 310   (or (eq type1 type2)
 311       (invoke-alien-type-method :subtypep type1 type2)))
 312
 313 (defun compute-naturalize-lambda (type)
 314   `(lambda (alien ignore)
 315      (declare (ignore ignore))
 316      ,(invoke-alien-type-method :naturalize-gen type 'alien)))
 317
 318 (defun compute-deport-lambda (type)
 319   (declare (type alien-type type))
 320   (/noshow "entering COMPUTE-DEPORT-LAMBDA" type)
 321   (multiple-value-bind (form value-type)
 322       (invoke-alien-type-method :deport-gen type 'value)
 323     `(lambda (value ignore)
 324        (declare (type ,(or value-type
 325                            (compute-lisp-rep-type type)
 326                            `(alien ,type))
 327                       value)
 328                 (ignore ignore))
 329        ,form)))
 330
 331 (defun compute-deport-alloc-lambda (type)
 332   `(lambda (value ignore)
 333      (declare (ignore ignore))
 334      ,(invoke-alien-type-method :deport-alloc-gen type 'value)))
 335
 336 (defun compute-extract-lambda (type)
 337   (let ((extract (invoke-alien-type-method :extract-gen type 'sap 'offset)))
 338     `(lambda (sap offset ignore)
 339        (declare (type system-area-pointer sap)
 340                 (type unsigned-byte offset)
 341                 (ignore ignore))
 342        ,(if (eq (alien-type-class type) 'integer)
 343             extract
 344             `(naturalize ,extract ',type)))))
 345
 346 (defun compute-deposit-lambda (type)
 347   (declare (type alien-type type))
 348   `(lambda (value sap offset ignore)
 349      (declare (type system-area-pointer sap)
 350               (type unsigned-byte offset)
 351               (ignore ignore))
 352      (let ((alloc-tmp (deport-alloc value ',type)))
 353        (maybe-with-pinned-objects (alloc-tmp) (,type)
 354          (let ((value (deport alloc-tmp  ',type)))
 355            ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
 356            ;; Note: the reason we don't just return the pre-deported value
 357            ;; is because that would inhibit any (deport (naturalize ...))
 358            ;; optimizations that might have otherwise happen. Re-naturalizing
 359            ;; the value might cause extra consing, but is flushable, so probably
 360            ;; results in better code.
 361            (naturalize value ',type))))))
 362
 363 (defun compute-lisp-rep-type (type)
 364   (invoke-alien-type-method :lisp-rep type))
 365
 366 ;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
 367 ;;; return values).  See the :ALIEN-REP method for INTEGER for
 368 ;;; details.
 369 (defun compute-alien-rep-type (type &optional (context :normal))
 370   (invoke-alien-type-method :alien-rep type context))
 371 \f
 372 ;;;; default methods
 373
 374 (defun missing-alien-operation-error (type operation)
 375   (error "Cannot ~A aliens of type ~/sb!impl:print-type-specifier/."
 376          operation type))
 377
 378 (define-alien-type-method (root :unparse) (type)
 379   `(<unknown-alien-type> ,(type-of type)))
 380
 381 (define-alien-type-method (root :type=) (type1 type2)
 382   (declare (ignore type1 type2))
 383   t)
 384
 385 (define-alien-type-method (root :subtypep) (type1 type2)
 386   (alien-type-= type1 type2))
 387
 388 (define-alien-type-method (root :lisp-rep) (type)
 389   (declare (ignore type))
 390   nil)
 391
 392 (define-alien-type-method (root :alien-rep) (type context)
 393   (declare (ignore type context))
 394   '*)
 395
 396 (define-alien-type-method (root :naturalize-gen) (type alien)
 397   (declare (ignore alien))
 398   (missing-alien-operation-error "represent" type))
 399
 400 (define-alien-type-method (root :deport-gen) (type object)
 401   (declare (ignore object))
 402   (missing-alien-operation-error "represent" type))
 403
 404 (define-alien-type-method (root :deport-alloc-gen) (type object)
 405   (declare (ignore type))
 406   object)
 407
 408 (define-alien-type-method (root :deport-pin-p) (type)
 409   (declare (ignore type))
 410   ;; Override this method to return T for classes which take a SAP to a
 411   ;; GCable lisp object when deporting.
 412   nil)
 413
 414 (define-alien-type-method (root :extract-gen) (type sap offset)
 415   (declare (ignore sap offset))
 416   (missing-alien-operation-error "represent" type))
 417
 418 (define-alien-type-method (root :deposit-gen) (type sap offset value)
 419   `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
 420
 421 (define-alien-type-method (root :arg-tn) (type state)
 422   (declare (ignore state))
 423   (missing-alien-operation-error "pass as argument to CALL-OUT"
 424                                  (unparse-alien-type type)))
 425
 426 (define-alien-type-method (root :result-tn) (type state)
 427   (declare (ignore state))
 428   (missing-alien-operation-error "return from CALL-OUT"
 429                                  (unparse-alien-type type)))
 430 \f
 431 ;;;; the INTEGER type
 432
 433 (define-alien-type-class (integer)
 434   (signed t :type (member t nil)))
 435
 436 (define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits))
 437   (make-alien-integer-type :bits bits))
 438
 439 (define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits))
 440   (make-alien-integer-type :bits bits))
 441
 442 (define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits))
 443   (make-alien-integer-type :bits bits :signed nil))
 444
 445 (define-alien-type-method (integer :unparse) (type)
 446   (list (if (alien-integer-type-signed type) 'signed 'unsigned)
 447         (alien-integer-type-bits type)))
 448
 449 (define-alien-type-method (integer :type=) (type1 type2)
 450   (and (eq (alien-integer-type-signed type1)
 451            (alien-integer-type-signed type2))
 452        (= (alien-integer-type-bits type1)
 453           (alien-integer-type-bits type2))))
 454
 455 (define-alien-type-method (integer :lisp-rep) (type)
 456   (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 457         (alien-integer-type-bits type)))
 458
 459 (define-alien-type-method (integer :alien-rep) (type context)
 460   ;; When returning integer values that are narrower than a machine
 461   ;; register from a function, some platforms leave the higher bits of
 462   ;; the register uninitialized.  On those platforms, we use an
 463   ;; alien-rep of the full register width when checking for purposes
 464   ;; of return values and override the naturalize method to perform
 465   ;; the sign extension (in compiler/target/c-call.lisp).
 466   (ecase context
 467     ((:normal #!-(or alpha x86 x86-64) :result)
 468      (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 469            (alien-integer-type-bits type)))
 470     #!+(or alpha x86 x86-64)
 471     (:result
 472      (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
 473            (max (alien-integer-type-bits type)
 474                 sb!vm:n-machine-word-bits)))))
 475
 476 ;;; As per the comment in the :ALIEN-REP method above, this is defined
 477 ;;; elsewhere for alpha and x86oids.
 478 #!-(or alpha x86 x86-64)
 479 (define-alien-type-method (integer :naturalize-gen) (type alien)
 480   (declare (ignore type))
 481   alien)
 482
 483 (define-alien-type-method (integer :deport-gen) (type value)
 484   (declare (ignore type))
 485   value)
 486
 487 (define-alien-type-method (integer :extract-gen) (type sap offset)
 488   (declare (type alien-integer-type type))
 489   (let ((ref-fun
 490          (if (alien-integer-type-signed type)
 491           (case (alien-integer-type-bits type)
 492             (8 'signed-sap-ref-8)
 493             (16 'signed-sap-ref-16)
 494             (32 'signed-sap-ref-32)
 495             (64 'signed-sap-ref-64))
 496           (case (alien-integer-type-bits type)
 497             (8 'sap-ref-8)
 498             (16 'sap-ref-16)
 499             (32 'sap-ref-32)
 500             (64 'sap-ref-64)))))
 501     (if ref-fun
 502         `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
 503         (error "cannot extract ~W-bit integers"
 504                (alien-integer-type-bits type)))))
 505 \f
 506 ;;;; the BOOLEAN type
 507
 508 (define-alien-type-class (boolean :include integer :include-args (signed)))
 509
 510 ;;; FIXME: Check to make sure that we aren't attaching user-readable
 511 ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
 512 (define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits))
 513   (make-alien-boolean-type :bits bits :signed nil))
 514
 515 (define-alien-type-method (boolean :unparse) (type)
 516   `(boolean ,(alien-boolean-type-bits type)))
 517
 518 (define-alien-type-method (boolean :lisp-rep) (type)
 519   (declare (ignore type))
 520   `(member t nil))
 521
 522 (define-alien-type-method (boolean :naturalize-gen) (type alien)
 523   (let ((bits (alien-boolean-type-bits type)))
 524     (if (= bits sb!vm:n-word-bits)
 525         `(not (zerop ,alien))
 526         `(logtest ,alien ,(ldb (byte bits 0) -1)))))
 527
 528 (define-alien-type-method (boolean :deport-gen) (type value)
 529   (declare (ignore type))
 530   `(if ,value 1 0))
 531 \f
 532 ;;;; the ENUM type
 533
 534 (define-alien-type-class (enum :include (integer (bits 32))
 535                                :include-args (signed))
 536   name          ; name of this enum (if any)
 537   from          ; alist from symbols to integers
 538   to            ; alist or vector from integers to symbols
 539   kind          ; kind of from mapping, :VECTOR or :ALIST
 540   offset)       ; offset to add to value for :VECTOR from mapping
 541
 542 (define-alien-type-translator enum (&whole
 543                                  type name
 544                                  &rest mappings
 545                                  &environment env)
 546   (cond (mappings
 547          (let ((result (parse-enum name mappings)))
 548            (when name
 549              (multiple-value-bind (old old-p)
 550                  (auxiliary-alien-type :enum name env)
 551                (when old-p
 552                  (unless (alien-type-= result old)
 553                    (cerror "Continue, clobbering the old definition"
 554                            "Incompatible alien enum type definition: ~S" name)
 555                    (setf (alien-enum-type-from old) (alien-enum-type-from result)
 556                          (alien-enum-type-to old) (alien-enum-type-to result)
 557                          (alien-enum-type-kind old) (alien-enum-type-kind result)
 558                          (alien-enum-type-offset old) (alien-enum-type-offset result)
 559                          (alien-enum-type-signed old) (alien-enum-type-signed result)))
 560                  (setf result old))
 561                (unless old-p
 562                  (setf (auxiliary-alien-type :enum name env) result))))
 563            result))
 564         (name
 565          (multiple-value-bind (result found)
 566              (auxiliary-alien-type :enum name env)
 567            (unless found
 568              (error "unknown enum type: ~S" name))
 569            result))
 570         (t
 571          (error "empty enum type: ~S" type))))
 572
 573 (defun parse-enum (name elements)
 574   (when (null elements)
 575     (error "An enumeration must contain at least one element."))
 576   (let ((min nil)
 577         (max nil)
 578         (from-alist ())
 579         (prev -1))
 580     (declare (list from-alist))
 581     (dolist (el elements)
 582       (multiple-value-bind (sym val)
 583           (if (listp el)
 584               (values (first el) (second el))
 585               (values el (1+ prev)))
 586         (setf prev val)
 587         (unless (symbolp sym)
 588           (error "The enumeration element ~S is not a symbol." sym))
 589         (unless (integerp val)
 590           (error "The element value ~S is not an integer." val))
 591         (unless (and max (> max val)) (setq max val))
 592         (unless (and min (< min val)) (setq min val))
 593         (when (rassoc val from-alist)
 594           (style-warn "The element value ~S is used more than once." val))
 595         (when (assoc sym from-alist :test #'eq)
 596           (error "The enumeration element ~S is used more than once." sym))
 597         (push (cons sym val) from-alist)))
 598     (let* ((signed (minusp min))
 599            (min-bits (if signed
 600                          (1+ (max (integer-length min)
 601                                   (integer-length max)))
 602                          (integer-length max))))
 603       (when (> min-bits 32)
 604         (error "can't represent enums needing more than 32 bits"))
 605       (setf from-alist (sort from-alist #'< :key #'cdr))
 606       (cond
 607        ;; If range is at least 20% dense, use vector mapping. Crossover
 608        ;; point solely on basis of space would be 25%. Vector mapping
 609        ;; is always faster, so give the benefit of the doubt.
 610        ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min)))))
 611         ;; If offset is small and ignorable, ignore it to save time.
 612         (when (< 0 min 10) (setq min 0))
 613         (let ((to (make-array (1+ (- max min)))))
 614           (dolist (el from-alist)
 615             (setf (svref to (- (cdr el) min)) (car el)))
 616           (make-alien-enum-type :name name :signed signed
 617                                 :from from-alist :to to :kind
 618                                 :vector :offset (- min))))
 619        (t
 620         (make-alien-enum-type :name name :signed signed
 621                               :from from-alist
 622                               :to (mapcar (lambda (x) (cons (cdr x) (car x)))
 623                                           from-alist)
 624                               :kind :alist))))))
 625
 626 (define-alien-type-method (enum :unparse) (type)
 627   `(enum ,(alien-enum-type-name type)
 628          ,@(let ((prev -1))
 629              (mapcar (lambda (mapping)
 630                        (let ((sym (car mapping))
 631                              (value (cdr mapping)))
 632                          (prog1
 633                              (if (= (1+ prev) value)
 634                                  sym
 635                                  `(,sym ,value))
 636                            (setf prev value))))
 637                      (alien-enum-type-from type)))))
 638
 639 (define-alien-type-method (enum :type=) (type1 type2)
 640   (and (eq (alien-enum-type-name type1)
 641            (alien-enum-type-name type2))
 642        (equal (alien-enum-type-from type1)
 643               (alien-enum-type-from type2))))
 644
 645 (define-alien-type-method (enum :lisp-rep) (type)
 646   `(member ,@(mapcar #'car (alien-enum-type-from type))))
 647
 648 (define-alien-type-method (enum :naturalize-gen) (type alien)
 649   (ecase (alien-enum-type-kind type)
 650     (:vector
 651      `(svref ',(alien-enum-type-to type)
 652              (+ ,alien ,(alien-enum-type-offset type))))
 653     (:alist
 654      `(ecase ,alien
 655         ,@(mapcar (lambda (mapping)
 656                     `(,(car mapping) ',(cdr mapping)))
 657                   (alien-enum-type-to type))))))
 658
 659 (define-alien-type-method (enum :deport-gen) (type value)
 660   `(ecase ,value
 661      ,@(mapcar (lambda (mapping)
 662                  `(,(car mapping) ,(cdr mapping)))
 663                (alien-enum-type-from type))))
 664 \f
 665 ;;;; the FLOAT types
 666
 667 (define-alien-type-class (float)
 668   (type (missing-arg) :type symbol))
 669
 670 (define-alien-type-method (float :unparse) (type)
 671   (alien-float-type-type type))
 672
 673 (define-alien-type-method (float :lisp-rep) (type)
 674   (alien-float-type-type type))
 675
 676 (define-alien-type-method (float :alien-rep) (type context)
 677   (declare (ignore context))
 678   (alien-float-type-type type))
 679
 680 (define-alien-type-method (float :naturalize-gen) (type alien)
 681   (declare (ignore type))
 682   alien)
 683
 684 (define-alien-type-method (float :deport-gen) (type value)
 685   (declare (ignore type))
 686   value)
 687
 688 (define-alien-type-class (single-float :include (float (bits 32))
 689                                        :include-args (type)))
 690
 691 (define-alien-type-translator single-float ()
 692   (make-alien-single-float-type :type 'single-float))
 693
 694 (define-alien-type-method (single-float :extract-gen) (type sap offset)
 695   (declare (ignore type))
 696   `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
 697
 698 (define-alien-type-class (double-float :include (float (bits 64))
 699                                        :include-args (type)))
 700
 701 (define-alien-type-translator double-float ()
 702   (make-alien-double-float-type :type 'double-float))
 703
 704 (define-alien-type-method (double-float :extract-gen) (type sap offset)
 705   (declare (ignore type))
 706   `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
 707
 708 \f
 709 ;;;; the POINTER type
 710
 711 (define-alien-type-class (pointer :include (alien-value (bits
 712                                                          sb!vm:n-machine-word-bits)))
 713   (to nil :type (or alien-type null)))
 714
 715 (define-alien-type-translator * (to &environment env)
 716   (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env))))
 717
 718 (define-alien-type-method (pointer :unparse) (type)
 719   (let ((to (alien-pointer-type-to type)))
 720     `(* ,(if to
 721              (%unparse-alien-type to)
 722              t))))
 723
 724 (define-alien-type-method (pointer :type=) (type1 type2)
 725   (let ((to1 (alien-pointer-type-to type1))
 726         (to2 (alien-pointer-type-to type2)))
 727     (if to1
 728         (if to2
 729             (alien-type-= to1 to2)
 730             nil)
 731         (null to2))))
 732
 733 (define-alien-type-method (pointer :subtypep) (type1 type2)
 734   (and (alien-pointer-type-p type2)
 735        (let ((to1 (alien-pointer-type-to type1))
 736              (to2 (alien-pointer-type-to type2)))
 737          (if to1
 738              (if to2
 739                  (alien-subtype-p to1 to2)
 740                  t)
 741              (null to2)))))
 742
 743 (define-alien-type-method (pointer :deport-gen) (type value)
 744   (/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
 745   (values
 746    ;; FIXME: old version, highlighted a bug in xc optimization
 747    `(etypecase ,value
 748       (null
 749        (int-sap 0))
 750       (system-area-pointer
 751        ,value)
 752       ((alien ,type)
 753        (alien-sap ,value)))
 754    ;; new version, works around bug in xc optimization
 755    #+nil
 756    `(etypecase ,value
 757       (system-area-pointer
 758        ,value)
 759       ((alien ,type)
 760        (alien-sap ,value))
 761       (null
 762        (int-sap 0)))
 763    `(or null system-area-pointer (alien ,type))))
 764 \f
 765 ;;;; the MEM-BLOCK type
 766
 767 (define-alien-type-class (mem-block :include alien-value))
 768
 769 (define-alien-type-method (mem-block :extract-gen) (type sap offset)
 770   (declare (ignore type))
 771   `(sap+ ,sap (truncate ,offset sb!vm:n-byte-bits)))
 772
 773 (define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
 774   (let ((bits (alien-mem-block-type-bits type)))
 775     (unless bits
 776       (error "can't deposit aliens of type ~S (unknown size)" type))
 777     `(sb!kernel:system-area-ub8-copy ,value 0 ,sap
 778       (truncate ,offset sb!vm:n-byte-bits)
 779       ',(truncate bits sb!vm:n-byte-bits))))
 780 \f
 781 ;;;; the ARRAY type
 782
 783 (define-alien-type-class (array :include mem-block)
 784   (element-type (missing-arg) :type alien-type)
 785   (dimensions (missing-arg) :type list))
 786
 787 (define-alien-type-translator array (ele-type &rest dims &environment env)
 788
 789   (when dims
 790     (unless (typep (first dims) '(or index null))
 791       (error "The first dimension is not a non-negative fixnum or NIL: ~S"
 792              (first dims)))
 793     (let ((loser (find-if-not (lambda (x) (typep x 'index))
 794                               (rest dims))))
 795       (when loser
 796         (error "A dimension is not a non-negative fixnum: ~S" loser))))
 797
 798   (let ((parsed-ele-type (parse-alien-type ele-type env)))
 799     (make-alien-array-type
 800      :element-type parsed-ele-type
 801      :dimensions dims
 802      :alignment (alien-type-alignment parsed-ele-type)
 803      :bits (if (and (alien-type-bits parsed-ele-type)
 804                     (every #'integerp dims))
 805                (* (align-offset (alien-type-bits parsed-ele-type)
 806                                 (alien-type-alignment parsed-ele-type))
 807                   (reduce #'* dims))))))
 808
 809 (define-alien-type-method (array :unparse) (type)
 810   `(array ,(%unparse-alien-type (alien-array-type-element-type type))
 811           ,@(alien-array-type-dimensions type)))
 812
 813 (define-alien-type-method (array :type=) (type1 type2)
 814   (and (equal (alien-array-type-dimensions type1)
 815               (alien-array-type-dimensions type2))
 816        (alien-type-= (alien-array-type-element-type type1)
 817                      (alien-array-type-element-type type2))))
 818
 819 (define-alien-type-method (array :subtypep) (type1 type2)
 820   (and (alien-array-type-p type2)
 821        (let ((dim1 (alien-array-type-dimensions type1))
 822              (dim2 (alien-array-type-dimensions type2)))
 823          (and (= (length dim1) (length dim2))
 824               (or (and dim2
 825                        (null (car dim2))
 826                        (equal (cdr dim1) (cdr dim2)))
 827                   (equal dim1 dim2))
 828               (alien-subtype-p (alien-array-type-element-type type1)
 829                                (alien-array-type-element-type type2))))))
 830 \f
 831 ;;;; the RECORD type
 832
 833 (def!struct (alien-record-field)
 834   (name (missing-arg) :type symbol)
 835   (type (missing-arg) :type alien-type)
 836   (bits nil :type (or unsigned-byte null))
 837   (offset 0 :type unsigned-byte))
 838 (defmethod print-object ((field alien-record-field) stream)
 839   (print-unreadable-object (field stream :type t)
 840     (format stream
 841             "~S ~S~@[:~D~]"
 842             (alien-record-field-type field)
 843             (alien-record-field-name field)
 844             (alien-record-field-bits field))))
 845 (!set-load-form-method alien-record-field (:xc :target))
 846
 847 (define-alien-type-class (record :include mem-block)
 848   (kind :struct :type (member :struct :union))
 849   (name nil :type (or symbol null))
 850   (fields nil :type list))
 851
 852 (define-alien-type-translator struct (name &rest fields &environment env)
 853   (parse-alien-record-type :struct name fields env))
 854
 855 (define-alien-type-translator union (name &rest fields &environment env)
 856   (parse-alien-record-type :union name fields env))
 857
 858 ;;; FIXME: This is really pretty horrible: we avoid creating new
 859 ;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
 860 ;;; system already. This way forward-references sans fields get
 861 ;;; "updated" for free to contain the field info. Maybe rename
 862 ;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
 863 ;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
 864 (defun parse-alien-record-type (kind name fields env)
 865   (declare (type sb!kernel:lexenv-designator env))
 866   (flet ((frob-type (type new-fields alignment bits)
 867            (setf (alien-record-type-fields type) new-fields
 868                  (alien-record-type-alignment type) alignment
 869                  (alien-record-type-bits type) bits)))
 870       (cond (fields
 871              (multiple-value-bind (new-fields alignment bits)
 872                  (parse-alien-record-fields kind fields env)
 873                (let* ((old (and name (auxiliary-alien-type kind name env)))
 874                       (old-fields (and old (alien-record-type-fields old))))
 875                  (when (and old-fields
 876                             (notevery #'record-fields-match-p old-fields new-fields))
 877                    (cerror "Continue, clobbering the old definition."
 878                            "Incompatible alien record type definition~%Old: ~S~%New: ~S"
 879                            (unparse-alien-type old)
 880                            `(,(unparse-alien-record-kind kind)
 881                               ,name
 882                              ,@(let ((*record-types-already-unparsed* '()))
 883                                  (mapcar #'unparse-alien-record-field new-fields))))
 884                    (frob-type old new-fields alignment bits))
 885                  (if old-fields
 886                      old
 887                      (let ((type (or old (make-alien-record-type :name name :kind kind))))
 888                        (when (and name (not old))
 889                          (setf (auxiliary-alien-type kind name env) type))
 890                        (frob-type type new-fields alignment bits)
 891                        type)))))
 892             (name
 893              (or (auxiliary-alien-type kind name env)
 894                  (setf (auxiliary-alien-type kind name env)
 895                        (make-alien-record-type :name name :kind kind))))
 896             (t
 897              (make-alien-record-type :kind kind)))))
 898
 899 ;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union
 900 ;;; types. KIND is the kind we are paring the fields of, and FIELDS is the
 901 ;;; list of field specifications.
 902 ;;;
 903 ;;; Result is a list of field objects, overall alignment, and number of bits
 904 (defun parse-alien-record-fields (kind fields env)
 905   (declare (type list fields))
 906   (let ((total-bits 0)
 907         (overall-alignment 1)
 908         (parsed-fields nil))
 909     (dolist (field fields)
 910       (destructuring-bind (var type &key alignment bits offset) field
 911         (declare (ignore bits))
 912         (let* ((field-type (parse-alien-type type env))
 913                (bits (alien-type-bits field-type))
 914                (parsed-field
 915                 (make-alien-record-field :type field-type
 916                                          :name var)))
 917           (unless alignment
 918             (setf alignment (alien-type-alignment field-type)))
 919           (push parsed-field parsed-fields)
 920           (when (null bits)
 921             (error "unknown size: ~S" (unparse-alien-type field-type)))
 922           (when (null alignment)
 923             (error "unknown alignment: ~S" (unparse-alien-type field-type)))
 924           (setf overall-alignment (max overall-alignment alignment))
 925           (ecase kind
 926             (:struct
 927              (let ((offset (or offset (align-offset total-bits alignment))))
 928                (setf (alien-record-field-offset parsed-field) offset)
 929                (setf total-bits (+ offset bits))))
 930             (:union
 931              (setf total-bits (max total-bits bits)))))))
 932     (values (nreverse parsed-fields)
 933             overall-alignment
 934             (align-offset total-bits overall-alignment))))
 935
 936 (define-alien-type-method (record :unparse) (type)
 937   `(,(unparse-alien-record-kind (alien-record-type-kind type))
 938     ,(alien-record-type-name type)
 939     ,@(unless (member type *record-types-already-unparsed* :test #'eq)
 940         (push type *record-types-already-unparsed*)
 941         (mapcar #'unparse-alien-record-field
 942                 (alien-record-type-fields type)))))
 943
 944 (defun unparse-alien-record-kind (kind)
 945   (case kind
 946     (:struct 'struct)
 947     (:union 'union)
 948     (t '???)))
 949
 950 (defun unparse-alien-record-field (field)
 951   `(,(alien-record-field-name field)
 952      ,(%unparse-alien-type (alien-record-field-type field))
 953      ,@(when (alien-record-field-bits field)
 954              (list :bits (alien-record-field-bits field)))
 955      ,@(when (alien-record-field-offset field)
 956              (list :offset (alien-record-field-offset field)))))
 957
 958 ;;; Test the record fields. Keep a hashtable table of already compared
 959 ;;; types to detect cycles.
 960 (defun record-fields-match-p (field1 field2)
 961   (and (eq (alien-record-field-name field1)
 962            (alien-record-field-name field2))
 963        (eql (alien-record-field-bits field1)
 964             (alien-record-field-bits field2))
 965        (eql (alien-record-field-offset field1)
 966             (alien-record-field-offset field2))
 967        (alien-type-= (alien-record-field-type field1)
 968                      (alien-record-field-type field2))))
 969
 970 (defvar *alien-type-matches* nil
 971   #!+sb-doc
 972   "A hashtable used to detect cycles while comparing record types.")
 973
 974 (define-alien-type-method (record :type=) (type1 type2)
 975   (and (eq (alien-record-type-name type1)
 976            (alien-record-type-name type2))
 977        (eq (alien-record-type-kind type1)
 978            (alien-record-type-kind type2))
 979        (eql (alien-type-bits type1)
 980             (alien-type-bits type2))
 981        (eql (alien-type-alignment type1)
 982             (alien-type-alignment type2))
 983        (flet ((match-fields (&optional old)
 984                 (setf (gethash type1 *alien-type-matches*) (cons type2 old))
 985                 (every #'record-fields-match-p
 986                        (alien-record-type-fields type1)
 987                        (alien-record-type-fields type2))))
 988          (if *alien-type-matches*
 989              (let ((types (gethash type1 *alien-type-matches*)))
 990                (or (memq type2 types) (match-fields types)))
 991              (let ((*alien-type-matches* (make-hash-table :test #'eq)))
 992                (match-fields))))))
 993 \f
 994 ;;;; the FUNCTION and VALUES alien types
 995
 996 ;;; Calling-convention spec, typically one of predefined keywords.
 997 ;;; Add or remove as needed for target platform.  It makes sense to
 998 ;;; support :cdecl everywhere.
 999 ;;;
1000 ;;; Null convention is supposed to be platform-specific most-universal
1001 ;;; callout convention. For x86, SBCL calls foreign functions in a way
1002 ;;; allowing them to be either stdcall or cdecl; null convention is
1003 ;;; appropriate here, as it is for specifying callbacks that could be
1004 ;;; accepted by foreign code both in cdecl and stdcall form.
1005 (def!type calling-convention () `(or null (member :stdcall :cdecl)))
1006
1007 ;;; Convention could be a values type class, stored at result-type.
1008 ;;; However, it seems appropriate only for epilogue-related
1009 ;;; conventions, those not influencing incoming arg passing.
1010 ;;;
1011 ;;; As of x86's :stdcall and :cdecl, supported by now, both are
1012 ;;; epilogue-related, but future extensions (like :fastcall and
1013 ;;; miscellaneous non-x86 stuff) might affect incoming argument
1014 ;;; translation as well.
1015
1016 (define-alien-type-class (fun :include mem-block)
1017   (result-type (missing-arg) :type alien-type)
1018   (arg-types (missing-arg) :type list)
1019   (stub nil :type (or null function))
1020   (convention nil :type calling-convention))
1021
1022 ;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
1023 ;;; convention specification for function types is unobvious.
1024 ;;;
1025 ;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
1026 ;;; starting with a convention keyword; its second item is a real
1027 ;;; result-type in this case. If convention is ever to become a part
1028 ;;; of result-type, such a syntax can be retained.
1029
1030 (define-alien-type-translator function (result-type &rest arg-types
1031                                                     &environment env)
1032   (multiple-value-bind (bare-result-type calling-convention)
1033       (typecase result-type
1034         ((cons calling-convention *)
1035            (values (second result-type) (first result-type)))
1036         (t result-type))
1037     (make-alien-fun-type
1038      :convention calling-convention
1039      :result-type (let ((*values-type-okay* t))
1040                     (parse-alien-type bare-result-type env))
1041      :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
1042                         arg-types))))
1043
1044 (define-alien-type-method (fun :unparse) (type)
1045   `(function ,(let ((result-type
1046                      (%unparse-alien-type (alien-fun-type-result-type type)))
1047                     (convention (alien-fun-type-convention type)))
1048                 (if convention (list convention result-type)
1049                     result-type))
1050              ,@(mapcar #'%unparse-alien-type
1051                        (alien-fun-type-arg-types type))))
1052
1053 (define-alien-type-method (fun :type=) (type1 type2)
1054   (and (alien-type-= (alien-fun-type-result-type type1)
1055                      (alien-fun-type-result-type type2))
1056        (eq (alien-fun-type-convention type1)
1057            (alien-fun-type-convention type2))
1058        (= (length (alien-fun-type-arg-types type1))
1059           (length (alien-fun-type-arg-types type2)))
1060        (every #'alien-type-=
1061               (alien-fun-type-arg-types type1)
1062               (alien-fun-type-arg-types type2))))
1063
1064 (define-alien-type-class (values)
1065   (values (missing-arg) :type list))
1066
1067 (define-alien-type-translator values (&rest values &environment env)
1068   (unless *values-type-okay*
1069     (error "cannot use values types here"))
1070   (let ((*values-type-okay* nil))
1071     (make-alien-values-type
1072      :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
1073                      values))))
1074
1075 (define-alien-type-method (values :unparse) (type)
1076   `(values ,@(mapcar #'%unparse-alien-type
1077                      (alien-values-type-values type))))
1078
1079 (define-alien-type-method (values :type=) (type1 type2)
1080   (and (= (length (alien-values-type-values type1))
1081           (length (alien-values-type-values type2)))
1082        (every #'alien-type-=
1083               (alien-values-type-values type1)
1084               (alien-values-type-values type2))))
1085 \f
1086 ;;;; a structure definition needed both in the target and in the
1087 ;;;; cross-compilation host
1088
1089 ;;; information about local aliens. The WITH-ALIEN macro builds one of
1090 ;;; these structures and LOCAL-ALIEN and friends communicate
1091 ;;; information about how that local alien is represented.
1092 (def!struct (local-alien-info
1093              (:constructor make-local-alien-info
1094                            (&key type force-to-memory-p
1095                             &aux (force-to-memory-p (or force-to-memory-p
1096                                                         (alien-array-type-p type)
1097                                                         (alien-record-type-p type))))))
1098   ;; the type of the local alien
1099   (type (missing-arg) :type alien-type)
1100   ;; Must this local alien be forced into memory? Using the ADDR macro
1101   ;; on a local alien will set this.
1102   (force-to-memory-p nil :type (member t nil)))
1103 (!set-load-form-method local-alien-info (:xc :target))
1104 (defmethod print-object ((info local-alien-info) stream)
1105   (print-unreadable-object (info stream :type t)
1106     (format stream
1107             "~:[~;(forced to stack) ~]~S"
1108             (local-alien-info-force-to-memory-p info)
1109             (unparse-alien-type (local-alien-info-type info)))))
1110 \f
1111 ;;;; the ADDR macro
1112
1113 (sb!xc:defmacro addr (expr &environment env)
1114   #!+sb-doc
1115   "Return an Alien pointer to the data addressed by Expr, which must be a call
1116    to SLOT or DEREF, or a reference to an Alien variable."
1117   (let ((form (%macroexpand expr env)))
1118     (or (typecase form
1119           (cons
1120            (case (car form)
1121              (slot
1122               (cons '%slot-addr (cdr form)))
1123              (deref
1124               (cons '%deref-addr (cdr form)))
1125              (%heap-alien
1126               (cons '%heap-alien-addr (cdr form)))
1127              (local-alien
1128               (let ((info (let ((info-arg (second form)))
1129                             (and (consp info-arg)
1130                                  (eq (car info-arg) 'quote)
1131                                  (second info-arg)))))
1132                 (unless (local-alien-info-p info)
1133                   (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
1134                          form))
1135                 (setf (local-alien-info-force-to-memory-p info) t))
1136               (cons '%local-alien-addr (cdr form)))))
1137           (symbol
1138            (let ((kind (info :variable :kind form)))
1139              (when (eq kind :alien)
1140                `(%heap-alien-addr ',(info :variable :alien-info form))))))
1141         (error "~S is not a valid L-value." form))))
1142
1143 (/show0 "host-alieneval.lisp end of file")