From: <bdo...@la...> - 2007-06-28 04:23:45
|
On Wed, Jun 27, 2007 at 08:39:19PM -0500, William Harold Newman wrote: > On Thu, Jun 28, 2007 at 01:51:32AM +0100, Marco Monteiro wrote: > > The attached patch changes the code to facilitate a possible future > > implementation of modern mode Lisp. > > I'm not very enthusiastic about this. Of course I see the value to > those users who need to run code portably both under SBCL and under > Allegro and who also choose to configure Allegro in its nonportable > modern mode. However, safe cheap trivial changes though they are, they > also seem to come with a global requirement that SBCL's code continue > to conform to the ANSI-Standard-as-revised-by-Allegro in order to > avoid code rot. Enforcing that seems to involve manual tedium or extra > automated checks at compile time. Besides, strictly speaking you can get something very close to "modern"-mode SBCL without changing any code at all. After running this I can (defun square (x) (* x x)) and (square 4) => 16, so it must work perfectly! A saved core loads too. (Disclaimer: I wrote this for giggles, I never plan on using it. If it breaks you are legally entitled to keep both pieces. I may go to hell for even posting this. Do not taunt Happy Fun Ball.) ------------------------------------------------------------------------ (eval-when (:compile-toplevel :load-toplevel :execute) (defun get-primitive-object-offset (obj-name slot-name) (let ((obj (find obj-name sb-vm:*primitive-objects* :key #'sb-vm:primitive-object-name))) (let ((lowtag (eval (sb-vm:primitive-object-lowtag obj)))) (when lowtag (let ((slot (find slot-name (sb-vm:primitive-object-slots obj) :key #'sb-vm:slot-name))) (- (* (sb-vm:slot-offset slot) sb-vm:n-word-bytes) lowtag))))))) (defconstant +symbol-name-offset+ (get-primitive-object-offset 'symbol 'sb-vm::name)) (defun %set-symbol-name (sym name) (setf (sb-sys:sap-ref-word (sb-sys:int-sap (sb-kernel:get-lisp-obj-address sym)) +symbol-name-offset+) (sb-kernel:get-lisp-obj-address name))) (defun make-lisp-modern () (let ((symbols (make-hash-table)) (packages (list-all-packages))) (do-all-symbols (s) (setf (gethash s symbols) t)) ;; Hack up our symbols! (maphash (lambda (s ignore) (declare (ignore ignore)) (when (string= (symbol-name s) (string-upcase (symbol-name s))) (%set-symbol-name s (string-downcase (symbol-name s))))) symbols) ;; Oh nuts, rehash our packages, quick! (dolist (package packages) (dolist (table (list (sb-kernel:package-internal-symbols package) (sb-kernel:package-external-symbols package))) (sb-impl::resize-package-hashtable table (sb-impl::package-hashtable-size table)))) ;; Phew. (setf (readtable-case *readtable*) :preserve)) ;; We sure as hell can't claim this anymore. (setf *features* (remove :ansi-cl *features*)) (setf *features* (remove :common-lisp *features*))) ;;; (make-lisp-modern) ;;; (save-lisp-and-die "modern.core") ------------------------------------------------------------------------ -bcd |