X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=utilities.lisp;h=d524371058ec9b1d5901e7fa749bdbbd701eda01;hb=8035fae1dab4ff6ca9ce283671f8b1ee16b52c6a;hp=03486b9517838729b873cf10ac7d3ae8b12310a1;hpb=e4b053532fa7f21711799575d683bebb6c1e9568;p=cl-protobufs.git diff --git a/utilities.lisp b/utilities.lisp index 03486b9..d524371 100644 --- a/utilities.lisp +++ b/utilities.lisp @@ -1,8 +1,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; -;;; Confidential and proprietary information of ITA Software, Inc. ;;; +;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; -;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;; +;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Scott McKay ;;; ;;; ;;; @@ -11,97 +11,17 @@ (in-package "PROTO-IMPL") -;;; Code generation utilities - -;; "class-name" -> "ClassName" -(defun class-name->proto (x) - "Given a Lisp class name, returns a Protobufs message or enum name." - (remove-if-not #'alphanumericp - (camel-case (format nil "~A" x) :separators '(#\- #\_ #\/ #\. #\space)))) - -;; "enum-value" -> "ENUM_VALUE" -(defun enum-name->proto (x &optional prefix) - "Given a Lisp enum value name, returns a Protobufs enum value name." - (let* ((x (string-upcase (string x))) - (x (if (and prefix (starts-with x prefix)) (subseq x (length prefix)) x))) - (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_))) - (format nil "~{~A~^_~}" - (split-string x :separators '(#\- #\_ #\/ #\. #\space)))))) - -;; "slot-name" -> "slot_name" or "slotName" -(defvar *camel-case-field-names* nil) -(defun slot-name->proto (x) - "Given a Lisp slot name, returns a Protobufs field name." - (if *camel-case-field-names* - (remove-if-not #'alphanumericp - (camel-case-but-one (format nil "~A" x) :separators '(#\- #\_ #\/ #\. #\space))) - (let ((x (string-downcase (string x)))) - (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_))) - (format nil "~{~A~^_~}" - (split-string x :separators '(#\- #\_ #\/ #\. #\space))))))) - - -;; "ClassName" -> "class-name" -(defun proto->class-name (x &optional package) - "Given a Protobufs message or enum type name, returns a Lisp class or type name." - (let ((name (nstring-upcase (uncamel-case x)))) - (if package (intern name package) (make-symbol name)))) - -;; "ENUM_VALUE" -> "enum-name" -(defun proto->enum-name (x &optional package) - "Given a Protobufs enum value name, returns a Lisp enum value name." - (let ((name (format nil "~{~A~^-~}" - (split-string (string-upcase x) :separators '(#\_))))) - (if package (intern name package) (make-symbol name)))) - -;; "slot_name" or "slotName" -> "slot-name" -(defun proto->slot-name (x &optional package) - "Given a Protobufs field value name, returns a Lisp slot name." - (let ((name (format nil "~{~A~^-~}" (split-string (nstring-upcase (uncamel-case x)) :separators '(#\_))))) - (if package (intern name package) (make-symbol name)))) - - -(defun make-lisp-symbol (string) - "Intern a string of the 'package:string' and return the symbol." - (let* ((string (string string)) - (colon (position #\: string)) - (pkg (if colon (subseq string 0 colon) "KEYWORD")) - (sym (if colon (subseq string (+ colon 1)) string))) - (intern sym pkg))) - -#-quux -(defun fintern (format-string &rest format-args) - "Interns a new symbol in the current package." - (declare (dynamic-extent format-args)) - (intern (nstring-upcase (apply #'format nil format-string format-args)))) - -#-quux -(defun kintern (format-string &rest format-args) - "Interns a new symbol in the keyword package." - (declare (dynamic-extent format-args)) - (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD")) - - -(define-condition protobufs-warning (warning simple-condition) ()) - -(defun protobufs-warn (format-control &rest format-arguments) - (warn 'protobufs-warning - :format-control format-control - :format-arguments format-arguments)) - - -;;; Other utilities +;;; Optimized fixnum arithmetic -;; A parameterized list types for repeated fields (not type-checked!) -(deftype list-of (type) - (if (eq type 'null) - 'null - 'list)) +(eval-when (:compile-toplevel :load-toplevel :execute) +(defparameter $optimize-default '(optimize (speed 1) (safety 3) (debug 3)) + "Compiler optimization settings for safe, debuggable code.") +(defparameter $optimize-fast-unsafe '(optimize (speed 3) (safety 0) (debug 0)) + "Compiler optimization settings for fast, unsafe, hard-to-debug code.") -#-quux (progn +) ;eval-when -;;; Optimized fixnum arithmetic (defmacro i+ (&rest fixnums) `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n))))) @@ -150,23 +70,139 @@ (define-modify-macro idecf (&optional (delta 1)) i-) (defmacro ildb (bytespec value) - `(ldb ,bytespec (the fixnum ,value))) + `(the fixnum (ldb ,bytespec (the fixnum ,value)))) -;;; Collectors, etc +;;; String utilities + +(defun starts-with (string prefix &key (start 0)) + "Returns true if 'string' starts with the prefix 'prefix' (case insensitive)." + (and (i>= (length string) (i+ start (length prefix))) + (string-equal string prefix :start1 start :end1 (i+ start (length prefix))) + prefix)) + +(defun ends-with (string suffix &key (end (length string))) + "Returns true if 'string' ends with the prefix 'prefix' (case insensitive)." + (and (i>= end (length suffix)) + (string-equal string suffix :start1 (i- end (length suffix)) :end1 end) + suffix)) + +(defun strcat (&rest strings) + "Concatenate a bunch of strings." + (declare (dynamic-extent strings)) + (apply #'concatenate 'string strings)) + + +;; (camel-case "camel-case") => "CamelCase" +(defun camel-case (string &optional (separators '(#\-))) + "Take a hyphen-separated string and turn it into a camel-case string." + (let ((words (split-string string :separators separators))) + (format nil "~{~@(~A~)~}" words))) + +;; (camel-case-but-one "camel-case") => "camelCase" +(defun camel-case-but-one (string &optional (separators '(#\-))) + "Take a hyphen-separated string and turn its tail into a camel-case string." + (let ((words (split-string string :separators separators))) + (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words)))) + + +;; (uncamel-case "CamelCase") => "CAMEL-CASE" +;; (uncamel-case "TCPConnection") => "TCP-CONNECTION" +;; (uncamel-case "NewTCPConnection") => "NEW-TCP-CONNECTION" +;; (uncamel-case "new_RPC_LispService") => "NEW-RPC-LISP-SERVICE" +;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST" +;; (uncamel-case "TCP2Name3") => "TCP2-NAME3" +(defun uncamel-case (name) + "Take a camel-case string and turn it into a hyphen-separated string." + ;; We need a whole state machine to get this right + (labels ((uncamel (chars state result) + (let ((ch (first chars))) + (cond ((null chars) + result) + ((upper-case-p ch) + (uncamel (rest chars) 'upper + (case state + ((upper) + ;; "TCPConnection" => "TCP-CONNECTION" + (if (and (second chars) (lower-case-p (second chars))) + (list* ch #\- result) + (cons ch result))) + ((lower digit) (list* ch #\- result)) + (otherwise (cons ch result))))) + ((lower-case-p ch) + (uncamel (rest chars) 'lower + (cons (char-upcase ch) result))) + ((digit-char-p ch) + (uncamel (rest chars) 'digit + (cons ch result))) + ((or (eql ch #\-) (eql ch #\_)) + (uncamel (rest chars) 'dash + (cons #\- result))) + ((eql ch #\.) + (uncamel (rest chars) 'dot + (cons #\. result))) + (t + (error "Invalid name character: ~A" ch)))))) + (strcat (nreverse (uncamel (concatenate 'list name) nil ()))))) + + +(defun split-string (line &key (start 0) (end (length line)) (separators '(#\-))) + "Given a string 'string', splits it at each of the separators. + Returns a list of the string pieces, with empty pieces removed." + (unless (i= start end) + (loop for this fixnum = start then (i+ next 1) + for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line + :start this :end end) + end) + for piece = (string-right-trim '(#\space) (subseq line this next)) + when (not (i= (length piece) 0)) + collect piece + until (i>= next end)))) + + +;;; Managing symbols (defmacro with-gensyms ((&rest bindings) &body body) `(let ,(mapcar #'(lambda (b) `(,b (gensym ,(string b)))) bindings) ,@body)) -(defmacro with-prefixed-accessors (names (prefix object) &body body) - `(with-accessors (,@(loop for name in names - collect `(,name ,(fintern "~A~A" prefix name)))) - ,object - ,@body)) +(defun make-lisp-symbol (string) + "Intern a string of the 'package:string' and return the symbol." + (let* ((string (string string)) + (colon (position #\: string)) + (pkg (if colon (subseq string 0 colon) "KEYWORD")) + (sym (if colon (subseq string (+ colon 1)) string))) + (intern sym pkg))) + +(defun fintern (format-string &rest format-args) + "Interns a new symbol in the current package." + (declare (dynamic-extent format-args)) + (intern (nstring-upcase (apply #'format nil format-string format-args)))) + +(defun kintern (format-string &rest format-args) + "Interns a new symbol in the keyword package." + (declare (dynamic-extent format-args)) + (intern (nstring-upcase (apply #'format nil format-string format-args)) "KEYWORD")) + +(defun keywordify (x) + "Given a symbol designator 'x', return a keyword whose name is 'x'. + If 'x' is nil, this returns nil." + (check-type x (or string symbol null)) + (cond ((null x) nil) + ((keywordp x) x) + ((symbolp x) (keywordify (symbol-name x))) + ((zerop (length x)) nil) + ((string-not-equal x "nil") + (intern (string-upcase x) (find-package "KEYWORD"))) + (t nil))) + +;;; Collectors, etc (defmacro with-collectors ((&rest collection-descriptions) &body body) + "'collection-descriptions' is a list of clauses of the form (coll function). + The body can call each 'function' to add a value to 'coll'. 'function' + runs in constant time, regardless of the length of the list." (let ((let-bindings ()) (flet-bindings ()) (dynamic-extents ()) @@ -192,10 +228,46 @@ `((declare (dynamic-extent ,@dynamic-extents)))) ,@body)))) +(defmacro with-prefixed-accessors (names (prefix object) &body body) + `(with-accessors (,@(loop for name in names + collect `(,name ,(fintern "~A~A" prefix name)))) + ,object + ,@body)) -;;; Function programming, please +(defmacro dovector ((var vector &optional value) &body body) + "Like 'dolist', but iterates over the vector 'vector'." + (with-gensyms (vidx vlen vvec) + `(let* ((,vvec ,vector) + (,vlen (length ,vvec))) + (loop for ,vidx fixnum from 0 below ,vlen + as ,var = (aref ,vvec ,vidx) + do (progn ,@body) + finally (return ,value))))) + +(defmacro doseq ((var sequence &optional value) &body body) + "Iterates over a sequence, using 'dolist' or 'dovector' depending on + the type of the sequence. In optimized code, this turns out to be + faster than (map () #'f sequence). + Note that the body gets expanded twice!" + (with-gensyms (vseq) + `(let ((,vseq ,sequence)) + (if (vectorp ,vseq) + (dovector (,var ,vseq ,value) + ,@body) + (dolist (,var ,vseq ,value) + ,@body))))) + + +(defmacro appendf (place tail) + "Append 'tail' to the list given by 'place', then set the place to the new list." + `(setf ,place (append ,place ,tail))) + + +;;; Functional programming, please (defun curry (function &rest args) + "Returns a function that applies 'function' to 'args', plus any + additional arguments given at the call site." (if (and args (null (cdr args))) ;fast test for length = 1 (let ((arg (car args))) #'(lambda (&rest more-args) @@ -214,52 +286,196 @@ form)) -;;; String utilities +;;; Types -(defun starts-with (string prefix &key (start 0)) - (and (i>= (length string) (i+ start (length prefix))) - (string-equal string prefix :start1 start :end1 (i+ start (length prefix))) - prefix)) +;; A parameterized list type for repeated fields +;; The elements aren't type-checked +(deftype list-of (type) + (if (eq type 'nil) ;a list that cannot have any element (element-type nil) is null + 'null + 'list)) -(defun ends-with (string suffix &key (end (length string))) - (and (i>= end (length suffix)) - (string-equal string suffix :start1 (i- end (length suffix)) :end1 end) - suffix)) +;; The same, but use a (stretchy) vector +(deftype vector-of (type) + (if (eq type 'nil) ;an array that cannot have any element (element-type nil) is of size 0 + '(array * (0)) + '(array * (*)))) ;a 1-dimensional array of any type + +;; This corresponds to the :bytes Protobufs type +(deftype byte-vector () '(array (unsigned-byte 8) (*))) + +(defun make-byte-vector (size) + (make-array size :element-type '(unsigned-byte 8))) + +;; The Protobufs integer types +(deftype int32 () '(signed-byte 32)) +(deftype int64 () '(signed-byte 64)) +(deftype uint32 () '(unsigned-byte 32)) +(deftype uint64 () '(unsigned-byte 64)) +(deftype sint32 () '(signed-byte 32)) +(deftype sint64 () '(signed-byte 64)) +(deftype fixed32 () '(signed-byte 32)) +(deftype fixed64 () '(signed-byte 64)) +(deftype sfixed32 () '(signed-byte 32)) +(deftype sfixed64 () '(signed-byte 64)) + +;; Type expansion +(defun type-expand (type) + #+(or abcl xcl) (system::expand-deftype type) + #+allegro (excl:normalize-type type :default type) + #+ccl (ccl::type-expand type) + #+clisp (ext:type-expand type) + #+cmu (kernel:type-expand type) + #+(or ecl mkcl) (si::expand-deftype type) + #+lispworks (type:expand-user-type type) + #+sbcl (sb-ext:typexpand type) + #-(or abcl allegro ccl clisp cmu ecl lispworks mkcl sbcl xcl) type) -;; (camel-case "camel-case") => "CamelCase" -(defun camel-case (string &key (separators '(#\-))) - (let ((words (split-string string :separators separators))) - (format nil "~{~@(~A~)~}" words))) +;;; Code generation utilities -;; (camel-case-but-one "camel-case") => "camelCase" -(defun camel-case-but-one (string &key (separators '(#\-))) - (let ((words (split-string string :separators separators))) - (format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words)))) +(defparameter *proto-name-separators* '(#\- #\_ #\/ #\space)) +(defparameter *camel-case-field-names* nil) + +(defun find-proto-package (name) + "A very fuzzy definition of 'find-package'." + (typecase name + ((or string symbol) + ;; Try looking under the given name and the all-uppercase name + (or (find-package (string name)) + (find-package (string-upcase (string name))))) + (cons + ;; If 'name' is a list, it's actually a fully-qualified path + (or (find-proto-package (first name)) + (find-proto-package (format nil "~{~A~^.~}" name)))))) + +;; "class-name" -> "ClassName", ("ClassName") +;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass") +(defun class-name->proto (x) + "Given a Lisp class name, returns a Protobufs message or enum name. + The second value is the fully qualified name, as a list." + (let* ((xs (split-string (string x) :separators '(#\.))) + (ns (loop for x in (butlast xs) + collect (remove-if-not #'alphanumericp + (camel-case (format nil "~A" x) *proto-name-separators*)))) + (nx (car (last xs))) + (name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*)))) + (values name (append ns (list name)) + ;; This might be the name of a package, too + (format nil "~{~A~^.~}" (butlast xs))))) + +;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE") +;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE") +(defun enum-name->proto (x &optional prefix) + "Given a Lisp enum value name, returns a Protobufs enum value name. + The second value is the fully qualified name, as a list." + (let* ((xs (split-string (string x) :separators '(#\.))) + (ns (loop for x in (butlast xs) + collect (remove-if-not #'alphanumericp + (camel-case (format nil "~A" x) *proto-name-separators*)))) + (nx (string-upcase (car (last xs)))) + (nx (if (and prefix (starts-with nx prefix)) (subseq nx (length prefix)) nx)) + ;; Keep underscores, they are standards separators in Protobufs enum names + (name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_))) + (format nil "~{~A~^_~}" + (split-string nx :separators *proto-name-separators*))))) + (values name (append ns (list name)) + (format nil "~{~A~^.~}" (butlast xs))))) + +;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName") +;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name") +(defun slot-name->proto (x) + "Given a Lisp slot name, returns a Protobufs field name. + The second value is the fully qualified name, as a list." + (let* ((xs (split-string (string x) :separators '(#\.))) + (ns (loop for x in (butlast xs) + collect (remove-if-not #'alphanumericp + (camel-case (format nil "~A" x) *proto-name-separators*)))) + (nx (string-downcase (car (last xs)))) + (name (if *camel-case-field-names* + (remove-if-not #'alphanumericp + (camel-case-but-one (format nil "~A" nx) *proto-name-separators*)) + ;; Keep underscores, they are standards separators in Protobufs field names + (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_))) + (format nil "~{~A~^_~}" + (split-string nx :separators *proto-name-separators*)))))) + (values name (append ns (list name)) + (format nil "~{~A~^.~}" (butlast xs))))) + + +;; "ClassName" -> 'class-name +;; "cl-user.ClassName" -> 'cl-user::class-name +;; "cl-user.OuterClass.InnerClass" -> 'cl-user::outer-class.inner-class +(defun proto->class-name (x &optional package) + "Given a Protobufs message or enum type name, returns a Lisp class or type name. + This resolves Protobufs qualified names as best as it can." + (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x)) + :separators '(#\.))) + (pkg1 (and (cdr xs) (find-proto-package (first xs)))) + (pkgn (and (cdr xs) (find-proto-package (butlast xs)))) + (package (or pkg1 pkgn package)) + (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs))))) + (values (if package (intern name package) (make-symbol name)) package xs + ;; This might be the name of a package, too + (format nil "~{~A~^.~}" (butlast xs))))) + +;; "ENUM_VALUE" -> :enum-value +;; "cl-user.ENUM_VALUE" -> :enum-value +;; "cl-user.OuterClass.ENUM_VALUE" -> :enum-value +(defun proto->enum-name (x &optional package) + "Given a Protobufs enum value name, returns a Lisp enum value name. + This resolves Protobufs qualified names as best as it can." + (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x)) + :separators '(#\.))) + (pkg1 (and (cdr xs) (find-proto-package (first xs)))) + (pkgn (and (cdr xs) (find-proto-package (butlast xs)))) + (package (or pkg1 pkgn package)) + (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs))))) + (values (kintern name) package xs + (format nil "~{~A~^.~}" (butlast xs))))) + +;; "slot_name" or "slotName" -> 'slot-name +;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name +;; "cl-user.OuterClass.slot_name" -> 'cl-user::outer-class.slot-name +(defun proto->slot-name (x &optional package) + "Given a Protobufs field value name, returns a Lisp slot name. + This resolves Protobufs qualified names as best as it can." + (let* ((xs (split-string (substitute #\- #\_ (uncamel-case x)) + :separators '(#\.))) + (pkg1 (and (cdr xs) (find-proto-package (first xs)))) + (pkgn (and (cdr xs) (find-proto-package (butlast xs)))) + (package (or pkg1 pkgn package)) + (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs))))) + (values (if package (intern name package) (make-symbol name)) package xs + (format nil "~{~A~^.~}" (butlast xs))))) -;; (uncamel-case "CamelCase") => "Camel-Case" -(defun uncamel-case (string &key (separator #\-)) - (format nil (format nil "~~{~~A~~^~C~~}" separator) - (cl-ppcre:split "(?<=[a-z])(?=[A-Z])" string))) +;;; Warnings -(defun split-string (line &key (start 0) (end (length line)) (separators '(#\-))) - (unless (i= start end) - (loop for this fixnum = start then (i+ next 1) - for next fixnum = (or (position-if #'(lambda (ch) (member ch separators)) line - :start this :end end) - end) - for piece = (string-right-trim '(#\space) (subseq line this next)) - when (not (i= (length piece) 0)) - collect piece - until (i>= next end)))) +(define-condition protobufs-warning (warning simple-condition) ()) + +(defun protobufs-warn (format-control &rest format-arguments) + (warn 'protobufs-warning + :format-control format-control + :format-arguments format-arguments)) + + +#-(or allegro lispworks) +(defmacro without-redefinition-warnings (() &body body) + `(progn ,@body)) + +#+allegro +(defmacro without-redefinition-warnings (() &body body) + `(excl:without-redefinition-warnings ,@body)) -) ;#-quux +#+lispworks +(defmacro without-redefinition-warnings (() &body body) + `(let ((dspec:*redefinition-action* :quiet)) ,@body)) -;;; Floating point utilities +;;; Portable floating point utilities -#+(or abcl allegro cmu sbcl lispworks) +#+(or abcl allegro ccl cmu sbcl lispworks) (defun single-float-bits (x) (declare (type single-float x)) #+abcl (system:single-float-bits x) @@ -267,11 +483,12 @@ (excl:single-float-to-shorts x) (declare (type (unsigned-byte 16) high low)) (logior (ash high 16) low)) + #+ccl (ccl::single-float-bits x) #+cmu (kernel:single-float-bits x) #+sbcl (sb-kernel:single-float-bits x) #+lispworks (lispworks-float:single-float-bits x)) -#-(or abcl allegro cmu sbcl lispworks) +#-(or abcl allegro ccl cmu sbcl lispworks) (defun single-float-bits (x) (declare (type single-float x)) (assert (= (float-radix x) 2)) @@ -316,7 +533,7 @@ ((-1) (logior unsigned-result (- (expt 2 31))))))))) -#+(or abcl allegro cmu sbcl lispworks) +#+(or abcl allegro ccl cmu sbcl lispworks) (defun double-float-bits (x) (declare (type double-float x)) #+abcl (values (system:double-float-low-bits x) @@ -325,6 +542,9 @@ (excl:double-float-to-shorts x) (logior (ash us1 16) us0) (logior (ash us3 16) us2)) + #+ccl (multiple-value-bind (high low) + (ccl::double-float-bits x) + (values low high)) #+cmu (values (kernel:double-float-low-bits x) (kernel:double-float-high-bits x)) #+sbcl (values (sb-kernel:double-float-low-bits x) @@ -333,7 +553,7 @@ (values (logand #xffffffff bits) (ash bits -32)))) -#-(or abcl allegro cmu sbcl lispworks) +#-(or abcl allegro ccl cmu sbcl lispworks) (defun double-float-bits (x) (declare (type double-float x)) (assert (= (float-radix x) 2)) @@ -381,17 +601,18 @@ (values (logand #xffffffff result) (ash result -32))))))) -#+(or abcl allegro cmu sbcl lispworks) +#+(or abcl allegro ccl cmu sbcl lispworks) (defun make-single-float (bits) (declare (type (signed-byte 32) bits)) #+abcl (system:make-single-float bits) #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) bits) (ldb (byte 16 0) bits)) + #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits) #+cmu (kernel:make-single-float bits) #+sbcl (sb-kernel:make-single-float bits) #+lispworks (lispworks-float:make-single-float bits)) -#-(or abcl allegro cmu sbcl lispworks) +#-(or abcl allegro ccl cmu sbcl lispworks) (defun make-single-float (bits) (declare (type (signed-byte 32) bits)) (cond @@ -412,7 +633,7 @@ (* sign (expt 2.0 exponent) mantissa))))) -#+(or abcl allegro cmu sbcl lispworks) +#+(or abcl allegro ccl cmu sbcl lispworks) (defun make-double-float (low high) (declare (type (unsigned-byte 32) low) (type (signed-byte 32) high)) @@ -421,11 +642,12 @@ (ldb (byte 16 0) high) (ldb (byte 16 16) low) (ldb (byte 16 0) low)) + #+ccl (ccl::double-float-from-bits (logand high #xffffffff) low) #+cmu (kernel:make-double-float high low) #+sbcl (sb-kernel:make-double-float high low) #+lispworks (lispworks-float:make-double-float high low)) -#-(or abcl allegro cmu sbcl lispworks) +#-(or abcl allegro ccl cmu sbcl lispworks) (defun make-double-float (low high) (declare (type (unsigned-byte 32) low) (type (signed-byte 32) high))