[newLISP]比較関数の型チェックを少し厳しくする

gistfile1.sls

;; newLISPの比較関数はどんな型でもお構いなく比較するので少々不便 (文字列と数値の比較なんて誰得)
;; ということで引数の型が異なる比較の場合はエラーを吐くようにしてみる

;; 利用方法
;; このファイルをユーザ初期化ファイル(~/init.lsp)に追加
;;; コマンドライン引数を指定してnewlispを起動する
;; % newlisp --strict

;; FIXME: 複合型(リストとラムダ・マクロ)を扱えない、nilと空リストを区別していない

(define COMPARE_TYPE_MASK 0x000F)
(define (type-of x)
  (let ((types '("bool" "bool" "integer" "float" "string"
                 "symbol" "context" "primitive" "cdecl" "stdcall"
                 "quote" "list" "lambda" "macro" "array"
                 "dyn-symbol"           ; ?
                 )))
    (types (& COMPARE_TYPE_MASK ((dump x) 1)))))

(define (strict-compare)

  (define compare-fn-symbols
    '(= < > <= >= !=))

  (define (type-match-all?)
    (apply _= (map (lambda (x)
                       (nth (& 0x000F (nth 1 (dump x)))
                            ;; o nil,true
                            ;; o integer,float
                            ;; ? list,array(,string)
                            ;; ? primitive,cdecl
                            ;; ? lambda,macro(,list)
                            ;; ? symbol,dyn-symbol
                            '(0 0 1 1 2 3 4 5 6 7 8 9 10 11 12 13)))
                     $args)))

  (dolist (cmp compare-fn-symbols)
    ;; 二重定義は避ける
    (when (primitive? (eval cmp))
      (letex (_cmp (sym (append "_" (term cmp))))
        (constant '_cmp (eval cmp))
        (constant cmp
                  (lambda ()
                    (if (apply type-match-all? $args)
                        (apply _cmp $args)
                        (throw-error
                         (string "mismatch type: "
                                 (map (lambda (x)
                                        (list (type-of x) x))
                                      $args)))))))
      ))

  true)

(if (find "--strict" $main-args)
    (strict-compare))

;; EOF