--- dgnushack.el~ Mon Feb 12 21:54:27 2001 +++ dgnushack.el Wed Feb 28 23:38:33 2001 @@ -70,6 +70,93 @@ (while (consp (cdr x)) (pop x)) x)))) + + (define-compiler-macro coerce (&whole form x type) + (if (and (fboundp 'coerce) + (subrp (symbol-function 'coerce))) + form + `(let ((x ,x) + (type ,type)) + (cond ((eq type 'list) (if (listp x) x (append x nil))) + ((eq type 'vector) (if (vectorp x) x (vconcat x))) + ((eq type 'string) (if (stringp x) x (concat x))) + ((eq type 'array) (if (arrayp x) x (vconcat x))) + ((and (eq type 'character) (stringp x) (= (length x) 1)) + (aref x 0)) + ((and (eq type 'character) (symbolp x) + (= (length (symbol-name x)) 1)) + (aref (symbol-name x) 0)) + ((eq type 'float) (float x)) + ((typep x type) x) + (t (error "Can't coerce %s to type %s" x type)))))) + + (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys) + (if (and (fboundp 'merge) + (subrp (symbol-function 'merge))) + form + `(let ((type ,type) + (seq1 ,seq1) + (seq2 ,seq2) + (pred ,pred)) + (or (listp seq1) (setq seq1 (append seq1 nil))) + (or (listp seq2) (setq seq2 (append seq2 nil))) + (let ((res nil)) + (while (and seq1 seq2) + (if (funcall pred (car seq2) (car seq1)) + (push (pop seq2) res) + (push (pop seq1) res))) + (coerce (nconc (nreverse res) seq1 seq2) type))))) + + (define-compiler-macro subseq (&whole form seq start &optional end) + (if (and (fboundp 'subseq) + (subrp (symbol-function 'subseq))) + form + (if end + `(let ((seq ,seq) + (start ,start) + (end ,end)) + (if (stringp seq) + (substring seq start end) + (let (len) + (if (< end 0) + (setq end (+ end (setq len (length seq))))) + (if (< start 0) + (setq start (+ start (or len (setq len (length seq)))))) + (cond ((listp seq) + (if (> start 0) + (setq seq (nthcdr start seq))) + (let ((res nil)) + (while (>= (setq end (1- end)) start) + (push (pop seq) res)) + (nreverse res))) + (t + (let ((res (make-vector (max (- end start) 0) nil)) + (i 0)) + (while (< start end) + (aset res i (aref seq start)) + (setq i (1+ i) + start (1+ start))) + res)))))) + `(let ((seq ,seq) + (start ,start)) + (if (stringp seq) + (substring seq start) + (let (len) + (if (< start 0) + (setq start (+ start (or len (setq len (length seq)))))) + (cond ((listp seq) + (if (> start 0) + (setq seq (nthcdr start seq))) + (copy-sequence seq)) + (t + (let* ((end (or len (length seq))) + (res (make-vector (max (- end start) 0) nil)) + (i 0)) + (while (< start end) + (aset res i (aref seq start)) + (setq i (1+ i) + start (1+ start))) + res))))))))) ) ;; If we are building w3 in a different directory than the source