Powered by ViewCVS 1.0-dev
seems to work; clean source example inline
;;; $Id: bleach.lisp,v 1.2 2006/02/13 00:40:08 mca1001 Exp $
;;; This is a cheerfully sick bit of Common Lisp to encode your
;;; program source as assorted whitespace characters. See also the
;;; Perl module Acme::Bleach.
;;;
;;; I wrote this because
;;;
;;; - it appears to be fairly easy to do
;;;
;;; - it proves that the set of daft tricks Perl can do overlaps at
;;; least to some extent with what Lisp can do
;;;
;;; - it's a small, self-contained program which I can write while
;;; I'm learning and throwing away. Except I shall probably leave it
;;; kicking around instead.
;;;
;;; Unfinished of course.
(defpackage #:org.t8o.bleach
(:use #:cl)
(:export #:bleach-it #:install-bleach #:uninstall-bleach))
(in-package #:org.t8o.bleach)
(provide 'org.t8o.bleach)
;; looks rather like I'm just messing about with CLOS here...
(defgeneric bleach-it (source)
(:documentation "Given `source' in a normal format, return or write
the content in a bleached form."))
(defmethod bleach-it ((source string))
"Bleach a string of Lisp `source'. Returns the bleached string."
(with-output-to-string (out)
(with-input-from-string (in source)
(let ((io (make-two-way-stream in out)))
(bleach-it io)))))
;; XXX:STD my encoding is suddenly implementation dependent
(defconstant +max-bit-pos+ (ceiling (log char-code-limit 2)))
(defmethod bleach-it ((stream two-way-stream))
"Bleach source read from the `two-way-stream' `stream'. Writes
output back to `stream', returns nil. Unless it fails."
(let ((src (two-way-stream-input-stream stream))
(dst (two-way-stream-output-stream stream))
(rev-ws (rev-assoc +ws-chars+)))
(let ((*package* (find-package 'cl))) ; to get full symbol names
(format dst "~{~&~s~}~%#"
;;; XXX: could avoid the #\# but then I'd have to make sure I restore original meanings
'((require :org.t8o.bleach) ; XXX: this is not enough to find and load it
(install-bleach)))) ; XXX: should uninstall after
;; there should be symmetry here with #'unbleach, but I made none
(loop for ch = (read-char src nil nil) do
(if (null ch) (return))
(loop for bitpos from +max-bit-pos+ downto 0
with have-one = nil
for bitval = (ldb (byte 1 bitpos) (char-code ch)) do
(if (= 1 bitval) (setf have-one t))
(if have-one
(write-char (cdr (assoc bitval rev-ws :test #'eql))
; screwed if +ws-chars+ is broken
dst)))
(write-char (cdr (assoc t rev-ws)) dst))))
;; (defmethod bleach-it ((source pathname))
;; "Bleach the source file stored at path `source'."
;;
;; (with-open-file (dst (argh 'make-dest-pathname 'now-is-not-the-time)
;; :direction :output :if-exists :supersede)
;; (with-open-file (src source)
;; (bleach-it (make-two-way-stream src dst)))))
(defun unbleach-it (string)
(with-output-to-string (out) ; losing track of how many of these I nested 8-(
(let ((accum 0))
(flet ((push-bit (bit)
(setf accum (logior (ash accum 1) bit)))
(done-char ()
(write-char (code-char accum) out)
(setf accum 0)))
(loop for ch across string
do
(let ((val (cdr (assoc ch +ws-chars+ :test #'eql))))
(cond ((null val)) ; ignore unknown chars
((eq t val)
(done-char))
(t
(push-bit val)))))))))
(defun rev-assoc (alist)
"Build a new assoc-list from `alist', but with reversed car/cdr
pairs."
(let ((item (car alist)))
(if item
(acons (cdr item) (car item) (rev-assoc (cdr alist)))
nil)))
(defun unread-string (str &optional (stream *standard-input*))
"XXX:DUP this code stolen from perl-quote.lisp"
(declare (string str))
(loop for n downfrom (1- (length str)) to 0 do
(unread-char (elt str n) stream)))
(defun sharp-ws (stream char arg)
"Handles bleached source."
(declare (ignore arg))
(unread-char char stream) ; read it back as part of the stream
(let ((bleached (read-string-of stream #'is-ws)))
;; this isn't necessarily a good way to do it,
;; it's just a way that works in SBCL
(unread-string (unbleach-it bleached) stream))
(values))
(defun read-string-of (stream test)
(with-output-to-string (out)
(loop for ch = (read-char stream nil nil) do
(cond ((null ch)
(return))
((funcall test ch)
(princ ch out))
(t
(unread-char ch stream)
(return))))))
(defvar *old-sharpers* '()
"alist of (character . old-sharp-handler)")
;; The great advantage of using illegal reader macro characters is
;; that anyone else who's using them deserves to find that somebody
;; else is using them, or has reset them to be illegal. This cuts
;; both ways.
; (defparameter +ws-chars+ '((#\. . 0) (#\# . 1) (#\| . t)))
(defparameter +ws-chars+ '((#\Space . 0) (#\Tab . 1) (#\Newline . t))
"alist of (char . val) where each `char' is hereby declared
whitespace, numeric `val' are used for bit value. Support for data
symbols of bit length != 1 is missing.")
;; the encoding made of "() " seems to be an obvious one to use,
;; maybe install-bleach needs to take a string for setup
(rev-assoc +ws-chars+)
(defun install-bleach ()
(loop for (ch . ch2) in +ws-chars+
do
(unless (assoc ch *old-sharpers* :test #'eql)
(push (cons ch (get-dispatch-macro-character #\# ch)) *old-sharpers*))
(set-dispatch-macro-character #\# ch #'sharp-ws)))
(defun uninstall-bleach ()
(loop for (ch . old-sharp) in *old-sharpers*
do
(set-dispatch-macro-character #\# ch old-sharp))
(setf *old-sharpers* '()))
; (install-bleach)
; (uninstall-bleach)
(defun is-ws (ch)
(declare (character ch))
(assoc ch +ws-chars+ :test #'eql))
;;; Example
;;
#|
(with-open-file (dst #p"/home/mca1001/cvswork-toy/lisp/test-bleached.lisp"
:direction :output :if-exists :supersede)
(with-open-file (src #p"/home/mca1001/cvswork-toy/lisp/test.lisp")
(org.t8o.bleach:bleach-it (make-two-way-stream src dst))))
(load "test-bleached.lisp")
|#
;; bleached contents of test.lisp inserted in comment
#|(REQUIRE :ORG.T8O.BLEACH)
(ORG.T8O.BLEACH:INSTALL-BLEACH)
#
|#
|
Repository owner Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |