Type annotation syntax/tools for SKILL/SKILL++?

Hi Damien, I've written a bit of SKILL dealing with these so-called type specifiers.  I'll include the code in clear text below. My implementation is very basic, and probably has some performance issues, so I'd be happy for you to suggest modifications to it.  I hope this helps.

Kind Regards
Jim

;; 
;;         _               Copyright (c) 2007, 2008, 2009, 2010, 2011, 2012, 2013
;;       c a d e n c e     Cadence Design Systems                           
;;                         All Rights Reserved                              
;; 
;;
;; DISCLAIMER: The following code is provided for Cadence customers to use at
;; their own risk. The code may require modification to satisfy the
;; requirements of any user. The code and any modifications to the code may
;; not be compatible with current or future versions of Cadence products.
;; THE CODE IS PROVIDED "AS IS" AND WITH NO WARRANTIES, INCLUDING WITHOUT
;; LIMITATION ANY EXPRESS WARRANTIES OR IMPLIED WARRANTIES OF MERCHANTABILITY
;; OR FITNESS FOR A PARTICULAR USE.

;; Description:
;;
;; Extensible Type Definition Facility:

;; Defining Types:
;;   You may define low level types with SkxDefBaseType.
;;   You may use SkxDefType to define types in terms of other types.
;;   E.g., (SkxDefType foo (or fixnum (rex "^[0-9]+$")))
;; 
;;   Be careful to define package specific types with appropriate package prefixes.
;;
;; Checking Types:
;;   the
;;     asserts type at runtime evaluating to the given form
;;     if type matches.  E.g., sum=(SkxThe flonum a+b+c)
;;   SkxTypep
;;     returns TRUE or FALSE depending if an object is of a given type
;;     E.g., (SkxTypep 1 (or fixnum string (listOf symbol))) ==> TRUE
;;   SkxTypeCase
;;     case statement where each clause checks a single particular type
;;     E.g., (SkxTypeCase x
;;             (flonum ...)
;;             (string ...)
;;             (t ...))
;;    SkxETypeCase
;;      exclusive version of SkxTypeCase, errors if no type matches.
;;


;; Global variable (alist) of all types currently defined.
(inSkill (defvar Skx_xtypes nil))

;; Global alist indicating the human readable type
;; defs.  E.g., complex -> (or number adtComplex)
(inSkill (defvar Skx_typedefs nil))

 
;; Expected to have one of the following values.
;; error - print to stderr if run-time type error is detected, 
;; warn - use warn if run-time type error is detected
;; ignore - do not do any run-time type checking.
;; noexpand - do not expand the macro into typechecking code, thus allowing
;;   run-time type errors to go unchecked.
(inSkill (defvar Skx_if_the_doesnotmatch (car '(error warn ignore noexpand))))


(importSkillVar Skx_if_the_doesnotmatch)

;; return the definition of a type as an sexpression.
(defun SkxTypeGetDef (name)
  (cadr (assq name (dynamic Skx_typedefs))))

(defun SkxMapTypes (client)
  (foreach mapcar x (dynamic Skx_typedefs)
    (client (car x))))

;; Define a base type which can be used with SkxTypep, SkxTypeCase, the etc...
;; SkxDefBaseType is used (instead of SkxDefType) to declare types in which
;; some specific SKILL code must run to determine whether an object is
;; of a certain type.  Presumably this type cannot be easily decomposed
;; into other types.
;; E.g., (SkxDefBaseType length (value len)
;;         (and (listp value)
;;              (eqv (length value) len)))
(defmacro SkxDefBaseType (typename arg @key def @rest body "glgg")
  (unless (atom typename)
    (error "[1815] invalid typename: %L" typename))
  (unless (or (symbolp typename)
              (null typename))
    (error "[1816] invalid type name: %L" typename))
  (unless body
    (error "[1817] invalid SkxDefBaseType: %L missing body" typename))
  `(progn
     ;; WARNING, this is not context compatible
     (pushf (list ',typename ',def)
            (dynamic Skx_typedefs))
     (setf (_Skx_xtypeFunction ',typename)
           (lambda ,(if (atom arg)
                        (list arg)
                        arg)
             ,@body))))

(defun setf__Skx_xtypeFunction (function typeName "Ug")
  (assert (or (null typeName)
              (symbolp typeName)))
  (when (assq typeName (dynamic Skx_xtypes))
    (warn "[1818] shadowing type definition for %L\n"
          typeName))
  (pushf (list typeName function)
         (dynamic Skx_xtypes)))

(defun _Skx_xtypeFunction (typeName)
  (cadr (assq typeName (inSkill Skx_xtypes))))

;; Determine whether the given value is of the given type specification.
;; You may use
;;    1. a class name such as VcadAuxListClass for a type,
;;    2. any a built-in SKILL type name such as fixnum
;;    3. any type defined by SkxDefBaseType or SkxDefType
;;    4. any valid on-the-fly type such as (or fixnum string)
;; 
;; E.g.,
;;  (SkxTypep 1 'fixnum) ==> non-nil
;;  (SkxTypep 1 t) ==> non-nil
;;  (SkxTypep nil 'null) ==> t
;;  (SkxTypep 1 'flonum) ==> nil
;;  (SkxTypep 1 '(satisfies oddp)) ==> non-nil
;;  (SkxTypep 1 '(not (satisfies stringp))) ==> non-nil
;;  (SkxTypep 1 '(or string
;;                 (satisfies numberp)
;;                 (not (and (satisfies stringp) t)))) ==> non-nil
(defgeneric SkxTypep (value typename)
                                        ;(SkxAdvise (ignore value))
            (error "[1819] cannot check invalid type %L of value %A" typename value))

;; everything is type t
(defmethod SkxTypep @around (_value (_typename (eqv t)))
  t)

;; nothing is type nil
(defmethod SkxTypep @around (_value (_typename (eqv nil)))
  nil)

(defmethod SkxTypep (value (typename list))
  (let ((fun (_Skx_xtypeFunction (car typename))))
    (cond ((null fun)
           (callNextMethod))
          (t
           (apply fun value (cdr typename))))))

;; This variable can be set to nil to cause SkxTypep to print
;; out debugging information.  This is potentially useful for
;; complicated combinational types applied to large data structures
;; for which it is not obvious which part of the type is failing to
;; match which part of the data structure.
;; Remember to set the variable back to nil when finished debugging.
;;
;; Note, this is a global lexical (not global dynamic) variable.  This
;; choice is inconvienent but intentional for performance to avoid
;; forcing the SkxTypep impelemention to use inSkill or let.
(defvar Skx_xtype_debug nil)

;; make sure SkxTypep returns explicitly t or nil.
;; Also check for Skx_xtype_debug in which case also output debug information
(defmethod SkxTypep @around (value typename)
  (if Skx_xtype_debug
      (if (callNextMethod)
          t
          (progn (info "[1820] NOT %L -->\n\t%L\n" typename value)
                 nil))
      (and (callNextMethod)
           t)))

;; handle the case of an explicit built-in skill type
;; or class name
;; or a symbolic type which has been registered into Skx_xtypes
(defmethod SkxTypep (value (typename symbol))
  (cond ((eq (type value) typename)
         t)
        ((findClass typename)
         (classp value typename))
        ((_Skx_xtypeFunction typename)
         (funcall (_Skx_xtypeFunction typename) value))
        (t
         (callNextMethod))))

(defmethod SkxTypep @around ((_value number) (_typename (eqv 'number)))
  t)

(defmethod SkxTypep @around (_value (_typename (eqv 'number)))
  nil)

(defmethod SkxTypep @around ((_value string) (_typename (eqv 'string)))
  t)

(defmethod SkxTypep @around (_value (_typename (eqv 'string)))
  nil)

(defmethod SkxTypep @around ((_value symbol) (_typename (eqv 'symbol)))
  t)

(defmethod SkxTypep @around (_value (_typename (eqv 'symbol)))
  nil)

(defmethod SkxTypep @around ((_value list) (_typename (eqv 'list)))
  t)

(defmethod SkxTypep @around (_value (_typename (eqv 'list)))
  nil)

;; every value is of type t
(SkxDefBaseType t (_value)
  t)

;; no value is of type nil
(SkxDefBaseType nil (_value)
  nil)

;; Check if an object is a member of a given list of object using the SKILL member function.
;; E.g., (SkxTypep 1.0 '(member 0 1 2 3 4)) ==> TRUE
(SkxDefBaseType member (value @rest elements)
   (member value elements))

;; Check if an object is a member of a given list of object using the SKILL memq function.
;; E.g., (SkxTypep 'x (memq w x y z)) ==> TRUE
(SkxDefBaseType memq (value @rest elements)
   (memq value elements))

;; Check if an object is a member of a given list of object using the SKILL memv function.
;; E.g., (SkxTypep 1 '(memv 0 1 2 3)) ==> TRUE
(SkxDefBaseType memv (value @rest elements)
   (memv value elements))

;; Check if an object matches a given predicate
;; E.g., (SkxTypep 3 '(satisfies oddp))  ==> TRUE
(SkxDefBaseType satisfies (value predicate)
   (funcall predicate value))

;; Check if an object is a list of EXACTLY the given length.
;; E.g., (SkxTypep '(10 20 30) '(length 3)) == TRUE
(SkxDefBaseType length (value len)
   (and (listp value)
     (eqv (length value) len)))

;; Check if an object is nil.  Only nil is of type null.
;; E.g., (SkxTypep nil 'null) ==> TRUE
(SkxDefBaseType null (value)
   (null value))

;; Check if an object is a number, possibly between given boundaries.
;; A single boundary is considered an upper-inclusive bound.
;; Two boundaries are considered lower and upper bounds, also inclusive.
;; E.g., (SkxTypep 3 'number) ==> TRUE
;;       (SkxTypep 2 '(number 3)) ==> TRUE because 2 <= 3
;;       (SkxTypep 2 '(number 0 3)) ==> TRUE because 0 <= 2 <= 3
(SkxDefBaseType number (value @rest boundaries)
  (cond
    ((null boundaries)
     (numberp value))
    ((ansiNotEvery numberp boundaries)
     (error "[1821] invalid type specified: %L" `(number ,@boundaries)))
    ((cdr boundaries)
     (destructuringBind (min max) boundaries
       (and (min <= value)
            (value <= max))))
    (t
     (value <= (car boundaries)))))

;; Check if an object is of all of several types.
;; E.g., (SkxTypep 1 '(and (number 0 100) 
;;                       (number -1000 1000))) ==> TRUE
(SkxDefBaseType and (value @rest typenames)
  (forall typename typenames
    (SkxTypep value typename)))

;; Check if an object is of any of several types.
;; E.g., (SkxTypep 1 '(or (number 1 100) 
;;                      (number -100 -1))) ==> TRUE
(SkxDefBaseType or (value @rest typenames)
  (exists typename typenames
    (SkxTypep value typename)))

;; Check if an object is NOT of a given type
;; E.g., (SkxTypep 1 '(not string)) ==> TRUE
(SkxDefBaseType not (value typename)
   (not (SkxTypep value typename)))

;; see http://en.wikipedia.org/wiki/XOR
;; for definition of n-ary xor.
;; Generalized or n-ary XOR is true when the number of TRUE inputs is odd.
;; E.g., (SkxTypep 2 '(xor string number)) ==> TRUE
;;       (SkxTypep 2 '(xor number fixnum))     ==> FALSE
(SkxDefBaseType xor (value @rest typenames)
  (oddp (let ((c 0))
          (foreach typename typenames
            (when (SkxTypep value typename)
              c++))
          c)))

;; Check if an object is a non-nil list.
(SkxDefBaseType cons (value)
  (dtpr value))

;; Check if a list is non-nil
;; and its car matches a type and its cdr matches a type.
;; E.g., (SkxTypep '(1 a b c)
;;              '(consOf fixnum (listOf symbol)))
;;
;; This type also has cons*/constar like syntax.
;; (SkxTypep '(1 2 3 a b c)
;;         '(consOf fixnum fixnum fixnum (listOf symbol)))
(SkxDefBaseType consOf (value car_type @rest cdr_type)
  (and (dtpr value)
       (SkxTypep (pop value) car_type)
       (if (null (cdr cdr_type))
           (SkxTypep value (car cdr_type))
           (SkxTypep value `(consOf ,@cdr_type)))))

;; This type matches a list starting with zero or more elements of
;; the LEADING type followed by the rest of the list matching the
;; TRAILING type.
;; E.g., (zeroOrMore number (listOf string))
;;   matches ("a" "b" "c")
;;   and also (1 "a" "b" "c")
;;   and also (1 2 "a" "b" "c")
;;   but not  (1 2 "a" 3 "b" "c")
(SkxDefBaseType zeroOrMore (value leading trailing)
  (and (listp value)
       (progn
         (while (and value
                     (SkxTypep (car value) leading))
           (pop value))
         (SkxTypep value trailing))))

;; This type matches a list starting with zero or more repetitions of elements
;; in turn matching LEADING followed by the rest of the list matching the
;; TRAILING type.
;; E.g., (zeroOrMoreGroups (symbol number number) (listOf string))
;;   matches ("a" "b" "c")
;;   and also (a 1 0 "a" "b" "c")
;;   and also (a 1 0 b 2 3 "a" "b" "c")
;;   and also (a 1 0 b 2 3) ;; because nil is a (listOf strings)
;;   but not  (a 1 0 b 2 3 "a" 3 "b" "c")
;; (zeroOrMoreGroups (symbol number) null)
;;   matches (a 100 b 200 c 300)
(SkxDefBaseType zeroOrMoreGroups (value leading trailing)
  (assert listp leading)
  (let ((leading_length (length leading)))
    (and (listp value)
         (progn
           ;; repeatedly skip over the first N elements of value
           ;; as long as the first N elements in-turn match the types of leading.
           (while (and (nthcdr (sub1 leading_length) value)
                       (ansiEvery (lambda (typename v)
                                    (SkxTypep v typename)) leading value))
             value = (nthcdr leading_length value))
           (SkxTypep value trailing)))))

;; Check if an object is an assoc list, i.e., a possibly empty list
;; of non-nil lists.
;; E.g., (SkxTypep '((1 100) (2 200)) 'alist) ==> TRUE
(SkxDefBaseType alist (value)
  (and (listp value)
       (forall x value (dtpr x))))

;; Check if an object is a DPL.  I.e., a non-nil list whose cdr is a plist.
;; E.g., (SkxTypep '(nil a 100 b 200) 'dpl) ==> TRUE
(SkxDefBaseType dpl (value)
  (and (dtpr value)
       (SkxTypep (cdr value) 'plist)))

;; Check if an object is a property list.  I.e., either nil or a list of
;; length at least 2, whose first element is a symbol and whose cddr is a plist.
;; E.g., (SkxTypep '(a 100 b 200) 'plist) ==> TRUE
(SkxDefBaseType plist (value)
  (or (null value)
      (and (while (and (cdr value)
                       (symbolp (car value)))
             value = (cddr value))
           (null value))))

;; Check if an object is eqv to a given object
;; E.g., (SkxTypep 1 '(eqv 1)) ==> TRUE
(SkxDefBaseType eqv (value object)
  (eqv value object))

;; Check if an object is eq to a given object
;; E.g., (SkxTypep 'x '(eq x)) ==> TRUE
(SkxDefBaseType eq (value object)
  (eq value object))

;; Check if an object is equal to a given object
;; E.g., (SkxTypep 1.0 '(equal 1)) ==> TRUE
(SkxDefBaseType equal (value object)
  (equal value object))

(defun Skx_checkPlistType (value @key required optional allowOthers (allowDuplicates t))
  (labels ((check (value done)
             (cond ((null value)
                    (forall pair required
                      (memq (car pair) done)))
                   ((null (cdr value))
                    nil)
                   ((null (symbolp (car value)))
                    nil)
                   ((memq (car value) done)
                    (if allowDuplicates
                        (check (cddr value) done)
                        nil))
                   ((assq (car value) required)
                    (and (SkxTypep (cadr value) (cadr (assq (car value) required)))
                         (check (cddr value) (cons (car value) done))))
                   ((assq (car value) optional)
                    (and (SkxTypep (cadr value) (cadr (assq (car value) optional)))
                         (check (cddr value) (cons (car value) done))))
                   (allowOthers
                    (check (cddr value) (cons (car value) done))))))
    (check value nil)))

;; Works analogously to dplOf.
(SkxDefBaseType plistOf (value @key required optional allowOthers (allowDuplicates t))
  (and (listp value)
       (Skx_checkPlistType value
                           ?allowDuplicates allowDuplicates
                           ?required required
                           ?optional optional
                           ?allowOthers allowOthers)))

;; required --> assoc list mapping keys which are required to an xtype name
;;
;; optional --> assoc list mapping optional keys to an xtype name
;;  (if a key is required and optional, then its entry in optional is ignored)
;;
;; allowOthers (default nil) --> boolean indicating whether keys not mentioned in
;;     ?required nor ?optional are allowed or not.
;;     E.g, (SkxTypep '(nil a 42 b 43) '(dplOf ?required ((a t))
;;                                             ?allowOthers t))
;;            ==> TRUE
;;     E.g, (SkxTypep '(nil a 42 b 43) '(dplOf ?required ((a t))
;;                                             ?allowOthers nil))
;;            ==> nil
;;
;; allowDuplicates (default t) --> t ==> duplicate keys are allowed,
;;                                nil==> duplicate keys are not allowed
;;     E.g., (SkxTypep '(nil a 42 a 43) '(dplOf ?required ((a t))
;;                                              ?allowDuplicates nil))
;;            ==> nil
;;     E.g., (SkxTypep '(nil a 42 a 43) '(dplOf ?required ((a t))
;;                                              ?allowDuplicates t))
;;            ==> TRUE
;;
;; first --> specifies the expected type of the first element of the DPL. 
;;
;; If duplicate keys are found, the type is ONLY CHECKED on the first occurance.
;;
;; E.g., (SkxThe (dplOf ?required ((a number)
;;                                 (b string))
;;                      ?optional ((c (or number
;;                                        string))
;;                                 (d list))
;;                      ?first string
;;                      ?allowOthers t
;;                      ?allowDuplicates nil)
;;            '("x" a 100
;;                  b "hello"
;;                  c "world"
;;                  d 42))
(SkxDefBaseType dplOf (value @key (first t) required optional allowOthers (allowDuplicates t))
  (and (dtpr value)
       (SkxTypep (car value) first)
       (Skx_checkPlistType (cdr value)
                           ?allowDuplicates allowDuplicates
                           ?required required
                           ?optional optional
                           ?allowOthers allowOthers)))

;; TRUE if the given value is a list and all the members of that list
;;  are of the named type.
;; E.g., (SkxTypep '(1) '(listOf fixnum)) ==> TRUE
;;       (SkxTypep '(1 2 3) '(listOf fixnum))  ==> TRUE
;;       (SkxTypep '("string" 1 2 3) '(listOf string fixnum))  ==> TRUE
(SkxDefBaseType listOf (value @optional typename @rest typenames)
  (cond ((null (listp value))
         nil)
        ((and (eq typename t) ;; don't bother checking if every element of the list is type t
              (forall name typenames
                (eq name t)))
         t)
        ((and typename typenames)
         (and (dtpr value)
              (SkxTypep (car value) typename)
              (SkxTypep (cdr value) (cons 'listOf typenames))))
        ((null typename)
         (error "[6941]: Nnot supported (listOf nil), if you know what that means, please implement it."))
        (t
         (forall element value
           (SkxTypep element typename)))))

;; Check if an object is a list of exactly the given types in the given order.
;; E.g., (SkxTypep '(1 "hello" world) '(eListOf number string symbol)) ==> TRUE
(SkxDefBaseType eListOf (value @rest typenames)
  (or (and (null value)
           (null typenames))
      (and (dtpr value)
           (dtpr typenames)
           (SkxTypep (car value) (car typenames))
           (SkxTypep (cdr value) (cons 'eListOf (cdr typenames))))))

;; Check if object is a sybol or string matching the given regular expression.
;; (SkxTypep "abcde" '(rex "b.*e$"))
;; (SkxTypep 'abcde '(rex "b.*e$"))
(SkxDefBaseType rex (value rex)
  (and (symstrp value)
       (rexMatchp rex (get_string value))))

;; Check if an object is a list which can be used as an arguement list to a function
;; with the given parameter list.
;; E.g., (SkxTypep '(1 2 ?x 3) '(callableAs a b @key x)) ==> TRUE
;; WARNING, the lambda list DOES have side effects, but those side efects are not LEXICAL
(SkxDefBaseType callableAs (value @rest lambdaList)
  (errset (apply `(lambda (@rest args)
                    (destructuringBind ,lambdaList args nil)) value)))

;; Check if an object is a list which can be used as an argument list to
;; a function with the given type template.
;; E.g., (SkxTypep '(1 2 3) '(typeTemplate "xnn")) ==> TRUE
;; WARNING (lambda ("") ..) does not mean an empty lambda list
;;    with an empty type template, but rather it is a SKILL error
(SkxDefBaseType typeTemplate (value template)
  (and (listp value)
       (errset (apply `(lambda ,(append (foreach mapcar _elt value (gensym))
                                        (list template)) nil)
                      value))))

;; Check if the object is a dbobject, and its objType is one
;; of the given strings.
;; E.g., (SkxTypep (geGetEditCellView) (objType "cellView"))
;; E.g., (SkxTypep (geGetEditCellView)~>shapes
;;               (listOf (objType "rect" "polygon" "path")))
(SkxDefBaseType objType (value @rest args)
  (and (isCallable 'dbobjectp)
       (dbobjectp value)
       (member value~>objType args)))

;; Define a new type in terms of existing types or in terms of itself
;; e.g.,
;; (SkxDefType newtype (or list string))
(defmacro SkxDefType (typename equivtype)
  `(SkxDefBaseType ,typename (value)
     ?def ,equivtype
     (SkxTypep value ',equivtype)))

(SkxDefType lambdaExpression (listOf (eqv lambda)
                                     list
                                     t
                                     t))

(SkxDefType callable (or binary funobj symbol lambdaExpression))

;; E.g., (SkxThe point (1 2))
(SkxDefType point (eListOf number number))

(SkxDefType orient (member "R0" "R90" "R180" "R270"
                           "MX" "MY" "MYR90" "MXR90"))

;; E.g., (xtype '((0 1) (2.3 4.5)) 'bBox)
(SkxDefType bBox (eListOf point point))

;; Check if the object is a transform which can be passed to functions
;; like dbMoveFig, dbCopyFig, dbConcatTransform, dbTransformBBox etc.
;; E.g., (SkxThe transform '((0 2) "R90" 2))
(SkxDefType transform
            (or (eListOf point orient)
                (eListOf point orient number)))

;; Check if an object is a symbol whose first character is ?
(SkxDefType keyword
            (and symbol
                 (satisfies (lambda (word)
                              (nindex (get_string word ) "?")))))

;; E.g.,
;; (SkxTypeCase some_value
;;    (fixnum ...)
;;    ((not flonum) ...)
;;    ((satisfies numberp) ...)
;;    ((or string symbol) ...)
;;    (t ...))
;; Each clause of the typecase may be a type which is
;;   valid for the SkxTypep function.
(defmacro SkxTypeCase (val @rest clauses)
  (letseq ((var (gensym))
           (converted (foreach mapcar clause clauses
                        (if (eq t (car clause))
                            clause
                            `((SkxTypep ,var (quote ,(car clause)))
                              ,@(cdr clause))))))
    `(let ((,var ,val))
       (cond ,@converted))))

;; exclusive type case, similar to ecase.
;; A error is evoked if there is no clause matching
;; the type of argument.
;; E.g., (SkxETypeCase 2.0
;;         (list ...)
;;         (string ...))
;;  evokes an error because 2.0 is neither a list nor a string.
(defmacro SkxETypeCase (val @rest clauses)
  (let ((var (gensym 'etypecase)))
    `(let ((,var ,val))
       (SkxTypeCase ,var
         ,@clauses
         (t (error "196: SkxETypeCase: no case for %L" ,var))))))

  
;; Similar to the CL THE special operator.
;; Evaluates to the value of the form if no type error is detected.
;; If type error is detected, different types of behavior will occure depending
;;   on load-time and runtime value of Skx_if_the_doesnotmatch.
;; This macro expands differently and behaves differently depending on the
;; value of the lexical global variable Skx_if_the_doesnotmatch.
;; If Skx_if_the_doesnotmatch='noexpand
;;    then (SkxThe ... foo) expands simply to foo.  This makes it possible to
;;    optimize away the type checking alltogether.
;; 
(defmacro SkxThe (valueType form)
  (if (eq Skx_if_the_doesnotmatch 'noexpand)
      ,form
      `(_Skx_the_assert_type ',valueType ,form ',form)))

;; Internal function used in the macro expansion of the
(defun _Skx_the_assert_type (valueType value form)
  (prog1
         value
    (cond
      ((eq Skx_if_the_doesnotmatch 'ignore))
      ((SkxTypep value valueType))
      (t
       (let ((format "invalid type of %L: expecting %L: not (%L) %L\n"))
         (funcall Skx_if_the_doesnotmatch
             format form valueType (type value) value))))))


(defmacro SkxWithTypeDefs (defs @rest body)
  (flet ((expand1 (pair)
           `(SkxDefType ,@pair)))
    `(dynamicLet ((Skx_xtypes (dynamic Skx_xtypes)))
       ,@(mapcar expand1 defs)
       ,@body)))

 Hi Damien, in case you find the SKILL++ code useful and want to modify it, here are some test cases you might also find helpful.
You'll probably need a couple of macro definitions.

;; This macro provides the ability to assert that an expression
;; evokes an error.
;; E.g., (assert_fails 1/0)
(defmacro assert_fails (expression)
  `(assert (not (errset ,expression))
     "EXPECTING FAILURE: %L\n"
     ',expression))

;; This macro is useful for building test cases. This macro attempts to output a helpful
;; message if the assertion fails.  The message includes the parameters to the testing
;; expression, and the values they evaluate to.
;; ARGUMENTS:
;;   expr - an expression to evaluate, asserting that it does not return nil
;;   ?ident ident - specifies an optional identifier which will be printed with [%L] in
;;                     the output if the assertion fails.  This will help you identify the
;;                     exact assertion that failed when scanning a testing log file.
;;   printf_style_args - additional printed information which will be output if the
;;                     assertion fails.
;;
;; E.g., (assert_test 1+1 == 2+2)
;; *Error* (1 + 1)
;;  --> 2
;; (2 + 2)
;;  --> 4
;; FAILED ASSERTION: ((1 + 1) == (2 + 2))
;; <<< Stack Trace >>>
(defmacro assert_test (expr @key ident @rest printf_style_args)
  (if (atom expr)
      `(assert ,expr)
      (let ((extra (if printf_style_args
                       `(strcat "\n" (_sprintf ,@printf_style_args))
                       "")))
        (destructuringBind (operator @rest operands) expr
          (letseq ((vars (foreach mapcar _operand operands
                           (gensym)))
                   (bindings (foreach mapcar (var operand) vars operands
                               (list var operand)))
                   (assertion `(,operator ,@vars))
                   (errors (foreach mapcar (var operand) vars operands
                             `(_sprintf "%L\n  --> %L" ',operand ,var))))
            `(let ,bindings
               (unless ,assertion
                 (error "%s%s%s"
                        (if ',ident
                            (sprintf nil "[%L] " ,ident)
                            "")
                        (buildString (list ,@errors
                                           (_sprintf "FAILED ASSERTION: %L" ',expr))
                                     "\n")
                        ,extra))))))))

(assert_fails (SkxTypep 3 (gensym)))
(assert_fails (SkxTypep 3 (list (gensym))))
(assert (not (SkxTypep nil '(dplOf ?required ((a number))))))
(assert (SkxTypep '(nil a 100) '(dplOf ?required ((a number)))))
(assert (not (SkxTypep '(nil a 100) '(dplOf ?required ((a string))))))
(assert (SkxTypep '(nil a 100) '(dplOf ?optional ((a number)))))
(assert (not (SkxTypep '(nil a 100) '(dplOf ?optional ((a string))))))
(assert (SkxTypep '(nil) '(dplOf ?optional ((a number)))))
(assert (SkxTypep '(nil a 100) '(dplOf ?optional ((b number))
                                     ?required ((a number)))))
(assert (not (SkxTypep '(nil b 100) '(dplOf ?optional ((b number))
                                          ?required ((a number))))))
(assert (SkxTypep '(42 a 100) '(dplOf ?first (eqv 42)
                                     ?optional ((b number))
                                     ?required ((a number)))))
(assert (not (SkxTypep '(nil 1 a 100)
                '(dplOf ?allowOthers t))))
(assert (not (SkxTypep '(nil a 100 b)
                '(dplOf ?allowOthers t))))
(assert (not (SkxTypep nil
                     '(dplOf ?allowOthers t))))

(assert (not (SkxTypep '(nil) '(dplOf ?first nil))))
(assert (SkxTypep '(nil)
                '(dplOf ?allowOthers nil)))
(assert (SkxTypep '(nil a 100 a "hello")
                '(dplOf ?required ((a number)))))
(assert (SkxTypep '(nil a 100 b 42 a "hello")
                '(dplOf ?optional ((b t))
                        ?required ((a number)))))
(assert (not (SkxTypep '(nil a 100 a 42)
                     '(dplOf ?allowDuplicates nil))))
(assert (not (SkxTypep '(nil a 100 a 42)
                     '(dplOf ?allowDuplicates nil
                             ?required ((a t))))))
(assert (SkxTypep '(nil a 100 b 42)
                '(dplOf ?allowDuplicates nil
                        ?required ((a number)
                                   (b number)))))
(assert (SkxTypep '(nil a 100 b 42 a 101)
                '(dplOf ?allowDuplicates t
                        ?required ((a number)
                                   (b number)))))
(assert (not (SkxTypep '(nil a 100 b 42 a 101)
                     '(dplOf ?allowDuplicates nil
                             ?required ((a number)
                                        (b number))))))


(assert (SkxTypep '(1 2 3 "x" "y" "z") '(zeroOrMore number (listOf string))))
(assert (SkxTypep '("x" "y" "z") '(zeroOrMore number (listOf string))))
(assert (SkxTypep '(1 2 3) '(zeroOrMore number (listOf string))))
(assert (not (SkxTypep '(1 2 3) '(zeroOrMore number (eListOf string)))))
(assert (not (SkxTypep '(1 2 3 nil "x" "y" "z") '(zeroOrMore number (listOf string)))))

(assert (SkxTypep '("a" "b" "c") '(zeroOrMoreGroups (symbol number) (listOf string))))
(assert (SkxTypep '(a 1 "a" "b" "c") '(zeroOrMoreGroups (symbol number) (listOf string))))
(assert (SkxTypep '(a 1 b 2 "a" "b" "c") '(zeroOrMoreGroups (symbol number) (listOf string))))
(assert (not (SkxTypep '(a 1 b 2 "a" 3 "b" "c") '(zeroOrMoreGroups (symbol number) (listOf string)))))
(assert (SkxTypep '(a 1 b 2) '(zeroOrMoreGroups (symbol number) (listOf string))))
(assert (not (SkxTypep '(a 1 b 2) '(zeroOrMoreGroups (symbol number) (eListOf string)))))

(assert (SkxTypep '("a" "b" "c") '(zeroOrMoreGroups (symbol number number) (listOf string))))
(assert (SkxTypep '(a 0 1 "a" "b" "c") '(zeroOrMoreGroups (symbol number number) (listOf string))))
(assert (SkxTypep '(a 0 1 b 2 3 "a" "b" "c") '(zeroOrMoreGroups (symbol number number) (listOf string))))
(assert (not (SkxTypep '(a 1 b 2 "a" 3 "b" "c") '(zeroOrMoreGroups (symbol number number) (listOf string)))))
(assert (not (SkxTypep '(a 0 1 b 2 3 "a" 3 "b" "c") '(zeroOrMoreGroups (symbol number number) (listOf string)))))

(assert (SkxTypep nil '(zeroOrMoreGroups (symbol number number) (listOf string))))
(assert (SkxTypep '(a 1 2) '(zeroOrMoreGroups (symbol number number) (listOf string))))

(assert (SkxTypep ?abc 'keyword))
(assert (not (SkxTypep 'abc 'keyword)))
(assert (not (SkxTypep nil 'keyword)))
(assert (not (SkxTypep "abc" 'keyword)))
(assert (not (SkxTypep "?abc" 'keyword)))

(assert (SkxThe lambdaExpression '(lambda () ())))
(assert (SkxThe lambdaExpression '(lambda (a b) (list a b))))
(assert_fails (SkxThe lambdaExpression '(lambda x x)))
(assert_fails (SkxThe lambdaExpression nil))
(assert_fails (SkxThe lambdaExpression ""))

(assert (SkxTypep '(1 2 3) '(consOf number (listOf number))))
(assert (SkxTypep '(1 2 3 x y z) '(consOf number number number (listOf symbol))))
(assert (not (SkxTypep '(1 2 3 x y z) '(consOf number number number (listOf number)))))


(assert (SkxTypep 1 t))
(assert (SkxTypep nil t))
(assert (not (SkxTypep nil nil)))
(assert (not (SkxTypep 1 nil)))

;; MEMBER
(assert_test 1 ==
	      (SkxThe (member 1) 1))
(assert_test 2 ==
	      (SkxThe (member 1 2) 2))

;; MEMQ
(assert_test 'x ==
	      (SkxThe (memq x) 'x))
(assert_test 'y ==
	      (SkxThe (memq x y z) 'y))

;; MEMV
(assert_test 2 ==
	      (SkxThe (memv 1 2 3) 2))

(assert_fails (SkxThe (memv 1 2 3) 1.0))


;; SATISFIES
(SkxThe (satisfies oddp) 3)
(assert_fails (SkxThe (satisfies oddp) 2))

;; LENGTH
(SkxThe (length 3) '(a b c))
(assert_fails (SkxThe (length 3) '(1 2)))
(assert_fails (SkxThe (length 3) '(1 2 3 4)))
(assert_fails (SkxThe (length 3) "hello"))

;; NULL
(SkxThe null nil)
(assert_fails (SkxThe null t))
(assert_fails (SkxThe null 42))

;; NUMBER
(SkxThe number 1)
(SkxThe number 1.0)
(assert_fails (SkxThe number "hello"))
(SkxThe (number 3) 2)
(SkxThe (number 3) 3)
(assert_fails (SkxThe (number 3) 4))
(SkxThe (number 3 6) 3)
(SkxThe (number 3 6) 4)
(SkxThe (number 3 6) 6)
(SkxThe (number 3 6) 6.0)
(assert_fails (SkxThe (number 3 6) 7))

;; AND
(SkxThe (and list
	  (length 3)) '(a b c))
(assert_fails (SkxThe (and list
			(length 3)) "hello"))
(SkxThe (and (satisfies plusp)
	  (satisfies oddp))  5)
(assert_fails (SkxThe (and (satisfies plusp)
			(satisfies oddp)) 4))
(assert_fails (SkxThe (and (satisfies plusp)
			(satisfies oddp)) -1))
(assert_fails (SkxThe (and (satisfies plusp)
			(satisfies oddp)) -4))

;; OR
(SkxThe (or string number) 3)
(SkxThe (or string number) 3.0)
(SkxThe (or string number) "hello")
(assert_fails (SkxThe (or string number) 'x))

;; NOT
(SkxThe (not string) 1.0)
(assert_fails (SkxThe (not string) "hello"))

;; XOR
(SkxThe (xor string number) 2)
(assert_fails (SkxThe (xor number fixnum) 2))
(SkxThe (xor number fixnum (satisfies oddp)) 3)
(SkxThe (xor number fixnum (satisfies oddp)) 2.0)

;; CONS
(SkxThe cons '(a))
(assert_fails (SkxThe cons nil))
(assert_fails (SkxThe cons 3))

;; ALIST
(SkxThe alist nil)
(SkxThe alist '((a 100)))
(SkxThe alist '((a 100) (b 200)))
(assert_fails (SkxThe alist '((a 100) nil)))
(assert_fails (SkxThe alist 2))

;; DPL
(SkxThe dpl '(a))
(SkxThe dpl '(a b 100))
(SkxThe dpl '(nil b 100 c 200))
(assert_fails (SkxThe dpl nil))
(assert_fails (SkxThe dpl 1))
(assert_fails (SkxThe dpl '(1 2)))
(assert_fails (SkxThe dpl '(1 2 3)))
(assert_fails (SkxThe dpl '(nil a 100 b)))

;; PLIST
(SkxThe plist nil)
(SkxThe plist '(b 100))
(SkxThe plist '(b 100 c 200))
(assert_fails (SkxThe plist 1))
(assert_fails (SkxThe plist '(1 2)))
(assert_fails (SkxThe plist '(1 2 3)))
(assert_fails (SkxThe plist '(nil a 100 b)))
(assert_fails (SkxThe plist '(a 100 b)))


;; LISTOF
(SkxThe (listOf fixnum) nil)
(SkxThe (listOf fixnum) '(1))
(SkxThe (listOf fixnum) '(1 2 3))
(SkxThe (listOf string fixnum) '("string" 1 2 3))
(assert_fails (SkxThe (listOf t t (eqv ?as) (member oodi cdf))
                   (list "l" "float" 1e-6)))
(assert_fails (SkxThe (list fixnum) 2))
(assert_fails (SkxThe (list fixnum) '(2.0)))
(assert_fails (SkxThe (list fixnum) '(1 2 3.0)))
(assert_fails (SkxThe (listOf symbol fixnum) '("string" 1 2 3)))

;; ELISTOF
(SkxThe (eListOf number string symbol) '(1 "hello" world))
(assert_fails (SkxThe (eListOf number string symbol) '(1 "hello" world world)))
(assert_fails (SkxThe (eListOf fixnum string symbol) '(1.0 "hello" world)))
(assert_fails (SkxThe (elistOf t t (eqv ?as) (member oodi cdf))
                   (list "l" "float" 1e-6)))
;; EQV
(SkxThe (eqv 1) 1)
(assert_fails (SkxThe (eqv 1) 2))
(assert_fails (SkxThe (eqv 1) 1.0))
(assert_fails (SkxThe (eqv 1) 1.0))
(assert_fails (SkxThe (eqv (1 2)) '(1 2)))

;; EQ
(SkxThe (eq x) 'x)
(assert_fails (SkxThe (eq x) 'y))
(assert_fails (SkxThe (eq (a b)) '(a b)))

;; EQUAL
(SkxThe (equal x) 'x)
(SkxThe (equal "x") "x")
(SkxThe (equal 1) 1)
(SkxThe (equal 1.0) 1.0)
(SkxThe (equal 1.0) 1)
(SkxThe (equal (1 2)) '(1 2))
(SkxThe (equal (1 2)) '(1.0 2.0))

;; REX
(SkxThe (rex "abc") "abc")
(SkxThe (rex "abc") "xxxabcxxx")
(SkxThe (rex "abc") 'xxxabcxxx)
(assert_fails (SkxThe (rex "^a") "bcd"))

;; CALLABLEAS
(SkxThe (callableAs a b @key x) '(1 2 ?x 3))
(inSkill
 (let ((a 100))
   (SkxThe (callableAs a b @key (x a++)) '(1 2))
   (assert (a != 100))))
	
;; TYPETEMPLATE
(SkxThe (typeTemplate "x") '(1))
(SkxThe (typeTemplate "xxt") '(1 2 "hello" "world"))

;; POINT
(SkxThe point '(1 2))
(SkxThe point '(1.0 2))
(SkxThe point '(1.0 2.0))
(assert_fails (SkxThe point '(1)))
(assert_fails (SkxThe point "x"))
(assert_fails (SkxThe point '(1 2 3)))

;; ORIENT
(SkxThe orient "R0")
(assert_fails (SkxThe orient "hello"))

;; BBOX
(SkxThe bBox '((0 0) (1 1)))
(assert_fails (SkxThe bBox '((0 0) 1)))

;; TRANSFORM
(SkxThe transform '((0 0) "R90" 1))
(SkxThe transform '((0 0) "R90" 1.0))
(SkxThe transform '((0 0) "R90"))
(assert_fails (SkxThe transform '((0 0) "R90" 2 3)))
(assert_fails (SkxThe transform '((0 0) "hello" 2)))

;; TYPECASE

(assert_test 42 ==
	      (SkxTypeCase 1
		(fixnum 42)
		(number 43)
		(string 44)))

(assert_test nil ==
	      (SkxTypeCase 1.0
		(fixnum 42)
		(symbol 43)
		(string 44)))

;; XETYPECASE
(assert_fails (SkxETypeCase 1.0
		(fixnum 42)
		(symbol 43)
		(string 44)))


;; test of SkxWithTypeDefs
(SkxWithTypeDefs ((foo (or string symbol))
                (bar (or number string)))
  (SkxThe foo "x")
  (SkxThe foo 'x)
  (SkxThe bar 12)
  (SkxThe bar "x")
  (SkxThe (listOf (or foo bar))
       '("x" x 12)))

Jim,

Excellent; thanks! That’s exactly what I was looking for: a list of used-in-the-wild type predicate symbols and their semantics… Of course, having a full implementation plus test suite does not hurt :)

My first remark, however, is that your Entreprise Forum Software is not 100% compatible with SKILL++—I very much doubt these “BLOCKED EXPRESSION”s figure in the original code.

More constructive comments:

• I feel better about conflating builtin and user-defined types, as I see you do it too :) I know it’s the case in CL, but its package system alleviates the effect;

• Interesting use of multimethods, which I suppose are faster than “manual” case-testing in SKILL. The downside is NO TYPE FOR YOU in old implementations :(

• Hmm… member, memq and memv. That makes sense, and my draft should switch to memv;

• null: I concur, even though null isn’t a type—or is it now?

• number: Will crash on (SkxTypep "Ha!" '(number 0 3)), and (possibly) on (SkxTypep "Ha!" '(number 1 2 3 4));

• keyword: Isn’t that predicate missing a onep?

• No tableOf or arrayOf in there; I suppose that’s how you would name them?

• I noticed callable and friends, but nothing akin to my lambda. Do you have plans for something like that? I’d suggest adopting CL:FUNCTION, with &rest and &key swapped.

Okay, that was a quick review; I wanted to get it there ASAP. I notice that you focused on the run-time aspects, and not on the presentation (i.e., no delimiters or infix hacks). Coming back to my little example, only lambda has to go:

;; Frobs Structs.
;;
;; @param {MyStruct}        s - The Struct to frob.
;; @param (or fixnum null)  n - A frobbing count, defaults to 1.
;; @param (or ? port)       with - The source of frobbing data.
;; @return {symbol}         Always t.
procedure( FrobAStruct(s with @key n)
  …
)

Unfortunately, I could not figure out a suitable replacement, so I’ll keep lambda for now.

I will put aside my cute infix hacks, and adopt your *Of convention.  I'll also test things with your implementation, and possibly suggest enhancements. Not sure when I’ll get to do that work, though, but I’ll keep you (and this thread!) posted.

Thanks, again!

Kind Regards,
Damien Diederen

–
http://crosstwine.com
tel: +49 89 2189 2939
cell: +49 174 3489 428

“Strong Opinions, Weakly Held”
— Bob Johansen

Hi Damien, this is funny about the  lambdaExpression.  I need to investigate further.  It looks like one occurance of the word lambdaExpression has been replaced with lambdaBLOCKED EXPRESSION.  I'll see if I can get this problem fixed.

With regard to the other problems you've found with my presented implementation. I'm happy to fix them in my implementation, update the test cases accordingly, and post the result (once the BLOCKED EXPRESSION issue is resolved).

Jim

Hi Damien, I'm attaching a zip file containing the SKILL++ code and test cases with the fixes for the bugs you found, and also avoiding the lambdaExpression problem.

Again, thanks for your feedback.

Kind regards.
Jim

Hi Jim,

Okay, got it—thanks!

I’ve also replied to your post on comp.lang.lisp regarding function types:

https://groups.google.com/d/msg/comp.lang.lisp/ALq9EmXT2r0/f88nM54LtI4J

I see where you are going with this, and I don’t think CL has a provision for such compound specifiers. I did not see anything relevant in e.g. http://discontinuity.info/~pkhuong/gf-sealing.lisp; perhaps perusing the SBCL/CMUCL implementations would be in order?

Unless somebody comes up with relevant prior art, I suggest you pick up a name as you are the native English speaker :)

Cheers, -D