From: Christophe R. <cr...@us...> - 2004-09-20 16:04:38
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2406/src/code Modified Files: Tag: character_branch primordial-extensions.lisp Log Message: 0.8.13.77.character.25: "It's all part of the learning experience" Preparation for widening CHARACTER. ... rewrite SYMBOLICATE to avoid needing the type system early; instead essentially provide a specialized implementation. ... slightly frob the CONCATENATE and REPLACE transforms (removing the REPLACE one completely for character strings, until the widening occurs). Index: primordial-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/primordial-extensions.lisp,v retrieving revision 1.31.12.1 retrieving revision 1.31.12.2 diff -u -d -r1.31.12.1 -r1.31.12.2 --- primordial-extensions.lisp 25 Aug 2004 20:26:25 -0000 1.31.12.1 +++ primordial-extensions.lisp 20 Sep 2004 16:04:29 -0000 1.31.12.2 @@ -167,30 +167,15 @@ ;;; producing a symbol in the current package. (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun symbolicate (&rest things) - (let ((name (case (length things) - ;; Why isn't this just the value in the T branch? - ;; Well, this is called early in cold-init, before - ;; the type system is set up; however, now that we - ;; check for bad lengths, the type system is needed - ;; for calls to CONCATENATE. So we need to make sure - ;; that the calls are transformed away: - (1 (concatenate 'string - (the simple-string - (string (car things))))) - (2 (concatenate 'string - (the simple-string - (string (car things))) - (the simple-string - (string (cadr things))))) - (3 (concatenate 'string - (the simple-string - (string (car things))) - (the simple-string - (string (cadr things))) - (the simple-string - (string (caddr things))))) - (t (apply #'concatenate 'string (mapcar #'string things)))))) - (values (intern name))))) + (let* ((length (reduce #'+ things + :key (lambda (x) (length (string x))))) + (name (make-array length :element-type 'character))) + (let ((index 0)) + (dolist (thing things (values (intern name))) + (let* ((x (string thing)) + (len (length x))) + (replace name x :start1 index) + (incf index len))))))) ;;; like SYMBOLICATE, but producing keywords (defun keywordicate (&rest things) |