Ignore:
Timestamp:
01/17/04 14:16:44 (18 years ago)
Author:
piso
Message:

NORMALIZE-TYPE

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/early-defuns.lisp

    r5300 r5486  
    11;;; early-defuns.lisp
    22;;;
    3 ;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: early-defuns.lisp,v 1.5 2004-01-01 01:38:00 piso Exp $
     3;;; Copyright (C) 2003-2004 Peter Graves
     4;;; $Id: early-defuns.lisp,v 1.6 2004-01-17 14:15:25 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2525           :format-control "The value ~S is not of type ~A."
    2626           :format-arguments (list arg type))))
     27
     28(defun normalize-type (type)
     29  (when (symbolp type)
     30    (case type
     31      (BIT
     32       (return-from normalize-type '(integer 0 1)))
     33      (CONS
     34       (return-from normalize-type '(cons t t)))
     35      (FIXNUM
     36       (return-from normalize-type
     37                    '(integer #.most-negative-fixnum #.most-positive-fixnum)))
     38      (SIGNED-BYTE
     39       (return-from normalize-type 'integer))
     40      (UNSIGNED-BYTE
     41       (return-from normalize-type '(integer 0 *)))
     42      (BASE-CHAR
     43       (return-from normalize-type 'character))
     44      ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
     45       (return-from normalize-type 'float))
     46      (t
     47       (unless (get type 'deftype-definition)
     48         (return-from normalize-type type)))))
     49  ;; Fall through...
     50  (let (tp i)
     51    (loop
     52      (if (consp type)
     53          (setf tp (car type) i (cdr type))
     54          (setf tp type i nil))
     55      (if (and (symbolp tp) (get tp 'deftype-definition))
     56          (setf type (apply (get tp 'deftype-definition) i))
     57          (return)))
     58    (case tp
     59      (CONS
     60       (let* ((len (length i))
     61              (car-typespec (if (> len 0) (car i) t))
     62              (cdr-typespec (if (> len 1) (cadr i) t)))
     63         (unless (and car-typespec cdr-typespec)
     64           (return-from normalize-type nil))
     65         (when (eq car-typespec '*)
     66           (setf car-typespec t))
     67         (when (eq cdr-typespec '*)
     68           (setf cdr-typespec t))
     69         (setf i (list car-typespec cdr-typespec))))
     70      ((ARRAY SIMPLE-ARRAY)
     71       (when (and i (eq (car i) nil)) ; Element type is NIL.
     72         (if (eq tp 'simple-array)
     73             (setf tp 'simple-string)
     74             (setf tp 'string))
     75         (when (cadr i) ; rank/dimensions
     76           (cond ((and (consp (cadr i)) (= (length (cadr i)) 1))
     77                  (if (eq (caadr i) '*)
     78                      (setf i nil)
     79                      (setf i (cadr i))))
     80                 ((eql (cadr i) 1)
     81                  (setf i nil))
     82                 (t
     83                  (error "invalid type specifier ~S" type))))))
     84      ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
     85       (setf tp 'float)))
     86    (if i (cons tp i) tp)))
    2787
    2888(defun caaaar (list) (car (car (car (car list)))))
Note: See TracChangeset for help on using the changeset viewer.