;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; $Header: /ct/ctlisp/compat.l,v 1.31 84/09/20 12:48:30 penny Exp $ ;;; ;;; Hacked 15 August 1985 by Richard Mark Soley for Lambda port ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; COMPAT ;;; ;;; ;;; ;;; Compatibility Macro Package for Franz (Unix and VMS) and LISPM. ;;; ;;; ;;; ;;; Mark L. Miller 4-Feb-83 ;;; ;;; See last page for edit history. ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (comment Assumes the presence of ct_load and suitable filemap) (eval-when (compile load eval) (ct_load 'aip)) ;;AIP macros pkg. (eval-when (compile load eval) (ct_load 'charmac)) ;;CT char set extensions. #+franz (eval-when (compile load eval) (ct_load 'format)) ;;Franz format pkg. #+franz (eval-when (compile load eval) (ct_load 'lispmloop)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;SAVE THIS COMMENTED OUT STUFF ;;;TEMPORARILY DISABLED TO IMPROVE PRODUCTIVITY ON INTERPRETER ;;;NEEDED FOR TUTOR BUT BELONGS IN ANOTHER FILE -- Thanks, Mark ;;; ;;;#+lispm (ct_load 'ct40ctc) ;For CT_LOGO ;;; ;;;#+lispm (ct_load 'littleada) ;For Little_Ada picture. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) ;;; This var should be bound non-nil IFF within a (*catch 'lossage -- ). (declare (special *lossage*)) (cond ((not (boundp '*lossage*)) (setq *lossage* nil))) #+franz (declare (special piport poport ER%tpl)) ;;;#+lispm (declare (special fonts:ct40ctc *little_ada*)) ;For CT_Logo, Ada. (declare (special *lose_stream*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; User-Callable Functions/Macros -- ;;; ;;;Revision 1.9 83/10/02 20:20:57 penny ;;;peter added nth to this function ;;;ct_typep (defun ct_typep (x) (#+lispm typep #+franz type x)) #+3600. (cond ((< (si:get-system-version) 242) (defmacro fixnum (&body body) nil))) #+LMI (defmacro fixnum (&body body) nil) ;;;A ct version of nth ... LM and franz have different semantics. ;(defun n_th(n l)(cond ((zerop n)(car l))(t (n_th (1- n)(cdr l))))) ;; lets use the primitives instead of recursion (defun n_th (n l) #+lispm (nth n l) #+franz (nthelem (1+ n) l)) ;;; It may be a bit more awkward to type (terminal_input) as a stream, ;;; but these ALWAYS WORK. USE THEM instead of t, nil, or any other ;;; thing that the compiler can get and define to be the wrong thing. #+lispm (eval-when (compile eval load) (progn 'compile (defun terminal_input macro (form) (selfinsertmacro form '(progn terminal-io))) (defun terminal_output macro (form) (selfinsertmacro form '(progn terminal-io))) (defun standard_input macro (form) (selfinsertmacro form '(progn standard-input))) (defun standard_output macro (form) (selfinsertmacro form '(progn standard-output))) )) #+franz (eval-when (compile eval load) (progn 'compile (defun terminal_input macro (form) (selfinsertmacro form '(progn t))) (defun terminal_output macro (form) (selfinsertmacro form '(progn t))) (defun standard_input macro (form) (selfinsertmacro form '(progn piport))) (defun standard_output macro (form) (selfinsertmacro form '(progn poport))) )) (eval-when (compile load eval) (defun error_output macro (form) (selfinsertmacro form #+franz `(progn poport) #+lispm `(progn error-output)))) (eval-when (compile load eval) (defun terminal-input macro (l) '(terminal_input)) (defun terminal-output macro (l) '(terminal_output)) (defun standard-input macro (l) '(standard_input)) (defun standard-output macro (l) '(standard_output))) (eval-when (load eval) (cond ((not (boundp '*lose_stream*)) (setq *lose_stream* (error_output))))) (defun ct_getcharn macro (form) ; To allow ourselves to keep using getcharn on the LISPM for now. (selfinsertmacro form #+lispm `(compiler-let ((obsolete-function-warning-switch nil)) (getcharn ,(cadr form) ,(caddr form))) #+franz `(getcharn ,(cadr form) ,(caddr form)))) (defun ct_nlistp macro (form) ; NB: Beware of (listp ())! (selfinsertmacro form #+franz `(not (listp ,(cadr form))) #+lispm `(let ((temp ,(cadr form))) ; Avoid duplicate evaluation. (not (or (null temp) (listp temp)))))) #+lispm (defun pp macro (form) ; Supply pp for LM. (selfinsertmacro form `(grindef ,(cadr form)))) #+franz (defun grindef macro (form) ; Supply grindef for Franz. (selfinsertmacro form `(pp ,(cadr form)))) (defun ct_mergef macro (form) ;;; Merge suitable defaults into filename (selfinsertmacro form #+lispm `(fs:merge-and-set-pathname-defaults ,(cadr form) ,(caddr form) '* ':newest) ;;; On unix, for now, just return the path (sigh) ++ #+unix `(progn ,(cadr form)) #+vms (lose 'not-implemented-yet 'ct_mergef))) (defun ct_probef macro (form) ;;; Because the value of probef differs across dialects. (selfinsertmacro form #+lispm `(probef ,(cadr form)) ; Winning version. ;;; On Franz, would like to get truename, but for now ... #+franz `(and (probef ,(cadr form)) ,(cadr form)))) (defun ct_closef macro (form) ;;; Perhaps unnecessary, but we may need to handle differently ;;; on different machines, eg., check if open before closing? ;;; For now, it is identical to close function on LM and Franz. (selfinsertmacro form `(close ,(cadr form)))) (defun with_open_infile macro (form) ;;;Usage: (with_open_infile (f '|foo.bar|) ... forms ...) (selfinsertmacro form (let ((streamvar (caadr form)) (filepath (cadadr form)) (forms (cddr form))) `(let ((,streamvar nil)) (unwind-protect ;;;Approximates WITH-OPEN-FILE. (progn (setq ,streamvar #+lispm (open ,filepath ':direction ':input ':characters t) #+franz (infile ,filepath) ) ,@forms) (ct_closef ,streamvar)))))) (defun with_open_outfile macro (form) ;;;Usage: (with_open_outfile (f '|foo.bar|) ... forms ...) (selfinsertmacro form (let ((streamvar (caadr form)) (filepath (cadadr form)) (forms (cddr form))) `(let ((,streamvar nil)) (unwind-protect ;;;Approximates WITH-OPEN-FILE. (progn (setq ,streamvar #+lispm (open ,filepath ':direction ':output ':characters t) #+franz (outfile ,filepath) ) ,@forms) (ct_closef ,streamvar)))))) #+franz (defun login-setq macro (form) (selfinsertmacro form `(setq ,(cadr form) ,(caddr form)))) #+franz (defun defvar macro (form) (selfinsertmacro form `(progn 'compile (declare (special ,(cadr form))) (or (boundp ',(cadr form)) (setq ,(cadr form) ,(caddr form)))))) #+franz ; Supply beeper for franz. (defun beep macro (form) (selfinsertmacro form '(tyo 7.))) (defun ct_intern macro (form) " Force LM to have ':user, since Franz does not have >1 obarrays. " (selfinsertmacro form #+lispm `(intern ,(cadr form) ':user) #+franz `(intern ,(cadr form)))) ;;; This defn functionally equiv. to that of the lisp machine. ;;; Form is (if test true-clause else-clause1 ...) #+franz (eval-when (compile load eval) (defun ct_if macro (form) (selfinsertmacro form `(cond (,(cadr form) ,(caddr form)) (t nil ,@(cdddr form)))))) ;;; For lispm, just equate if and ct_if. #+lispm ;(eval-when (compile load eval) ; (fset 'ct_if (fsymeval 'if))) (eval-when (compile load eval) (defmacro ct_if (&body body) `(if . ,body))) ;;; Another missing feature: Less than or equal. ;;; Identical to LM versions. #+franz (defmacro <= (&rest args) `(and ,@(loop for tail on args if (cadr tail) collect (list 'not (list '> (car tail) (cadr tail)))))) #+franz (defmacro >= (&rest args) `(and ,@(loop for tail on args if (cadr tail) collect (list 'not (list '< (car tail) (cadr tail)))))) (defun list_of_atoms_p (frob) (do ((x frob (cdr x))) ((atom x) t) (cond ((not (atom (car x))) (return nil))))) ;;; Internal function needed to hack append. THis appends ;;; exactly two lists nicely. #+franz (declare (localf append2)) #+franz (defun append2 (l1 l2) (cond ((null l1) l2) (t (cons (car l1) (append2 (cdr l1) l2))))) ;;; New, improved APPEND. Mark says that Franz is the only dialect ;;; he has ever heard of where append takes only two arguments. Foo. #+franz (defun append (&rest lists) (cond ;; If only one list provided, return it. ((null (cdr lists)) (car lists)) ;; Otherwise, recurse (t (append2 (car lists) (apply 'append (cdr lists)))))) ;;; Firstn returns the first n elements of a list #+franz (defun firstn (n list) (loop for item in list for i from 1 collect item until (= i n))) ;;; Identical to lisp machine version. #+franz (defun circular-list (&rest things) (rplacd (last things) things) things) ;;; Identical to LM version, although implemented differently. ;;; Is flatc really the "right thing" (versus flatsize, etc.)? -- mlm++ #+franz (defun string-length (string) (flatc string)) ;;; String append works with any number of arguments. Identical ;;; in function to the LM version. #+franz (defun string-append (&rest args) (do ((string nil) (list args (cdr list))) ((null list) (maknam string)) (ct_if (numberp (car list)) (setq string (append string (list (car list)))) (setq string (append string (exploden (car list))))))) ;;; Nbutlast destructively splices out the last element of a list, using ;;; rplacd. Sadly, this involves cdr'ing down the list. ;;; Identical to the LM version. #+franz (defun nbutlast (list) (do ((p1 list (cdr p1))) ((null (cddr p1)) (cond ((cdr p1) (rplacd p1 nil) list))))) ;;; It would be silly to expect Franz Lisp to have the ASS function. ;;; (ass fn key list) works like assq, except that fn is used instead of 'eq. ;;; Identical in function to the LM version #+franz (defun ass (fn key list) (do ((l list (cdr l))) ((null l) nil) (ct_if (apply fn (list key (caar l))) (return (car l))))) ;;; This renames a file from one name to another. In franz, ;;; this works by linking a file to a new name, and unlinking ;;; the old name. #+(and franz unix) ;Won't work on vms++ (defun ct_renamef (file1 file2) (syscall 9 file1 file2) ;;do the link (syscall 10 file1)) ;;and unlink original. #+lispm (defun ct_renamef (file1 file2) (renamef file1 file2)) ;;; Deletes a file. #+(and franz unix) ;Won't work on vms++ (defun ct_deletef (file) (syscall 10 file)) #+lispm (defun ct_deletef (file) (deletef file)) ; ct_open_in will open a file for input. #+franz (defun ct_open_in (file) (infile file)) #+lispm (defun ct_open_in (file) (open file)) ; ct_open_out will open a file for output. #+franz (defun ct_open_out (file) (outfile file)) #+lispm (defun ct_open_out (file) (open file 'OUT)) ;;; list_of_chars will return a list of small fixnums that are ;;; the characters in a given string. Hopefully, these chars ;;; are small enough to be eq some of the time. #+franz (defun list_of_chars (string) (exploden string)) #+lispm (defun list_of_chars (string) (loop for x from 0 to (1- (string-length string)) collect (aref string x))) ;;; this returns the nth character in a string. The first char ;;; is number 0. The franz version doesn't use NTHCHAR because ;;; we don't want to get back slashes, which nthchar will give ;;; you if you don't watch out. #+franz (defun ct_nth_char (string index) (nthelem (1+ index) (exploden string))) #+lispm (defun ct_nth_char (string index) (aref string index)) ; Extracts the nth element of a list. The 1th element is the car of the ; list. #+lispm (defun ct_nth (n list) (nth (1- n) list)) #+franz (defun ct_nth (n list) (nthelem n list)) ;;; Do something N times. The format is (ct_dotimes 5 (princ "foo")). #+lispm (defun ct_dotimes macro (form) `(dotimes (*_*incr*_* ,(cadr form)) ,@(cddr form))) #+franz (defun ct_dotimes macro (form) `(do ((*_*incr*_* 0 (1+ *_*incr*_*))) ((= *_*incr*_* ,(cadr form)) t) ,@(cddr form))) ;;; string-upcase and downcase don't come for free in franz. #+franz (defun string-upcase (string) (let ((chars (exploden string))) (do ((i chars (cdr i))) ((null i) (maknam chars)) (ct_if (<= #/a (car i) #/z) (rplaca i (- (car i) (- #/a #/A))))))) #+franz (defun string-downcase (string) (let ((chars (exploden string))) (do ((i chars (cdr i))) ((null i) (maknam chars)) (ct_if (<= #/A (car i) #/Z) (rplaca i (+ (car i) (- #/a #/A))))))) #+franz (defun copytree macro (form) (selfinsertmacro form `(subst nil nil ,(cadr form)))) #+franz ;;; (defun del (predicate itm lst &optional (times -1)) ;;; (loop for tail on (cons nil lst) with new-lst = tail until (zerop times) until (null (cdr tail)) if (funcall predicate itm (cadr tail)) do (rplacd tail (cddr tail)) finally (return (cdr new-lst)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;; LOSE (Win, Win) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initial Version of a Franz/LM Compatible Generalized Error ;;; Handling Facility. For all Ada*Tutor software. (defun abort (suicide?) (cond (suicide? #+franz (exit) #+lispm (tv:make-window 'tv:lisp-listener ':borders 4 ':vsp 2 ':activate-p t ':expose-p t ':label '(:top :string " ERROR: Please ask a C*T programmer for help." :font fonts:cptfontb))) (t #+franz (progn (resetio) (reset)) #+lispm (send current-process ':reset ':always)))) (defun lose (type ;Arbitrary symbol naming error. caller ;Name of function calling LOSE. &optional userfmt ;FORMAT string and args, for luser. debugfmt ;Ditto, for debugging. retval ;Value to return, if return. flags) ;Currently (reset) or (). (let ((handler (get type 'handler)) ;Data-driven handler capability. (errstrm *lose_stream*)) ;Avoid repeated spec lookups. (cond (handler (funcall handler type caller userfmt debugfmt retval flags)) (t (format errstrm "~2&") (cond (userfmt (apply (function format) (cons errstrm userfmt))) (t (format errstrm "An error has occurred."))) (format errstrm "~2%") (cond ((status feature debugging) (format errstrm "An error of type ~A has occurred.~%" type) (format errstrm "Called from within: ~A.~%" caller) (cond (debugfmt (apply (function format) (cons errstrm debugfmt))) (t (format errstrm "No other debug info available."))) (format errstrm "~2%") #+lispm (compiler-let ((obsolete-function-warning-switch nil)) ;;; We're gonna keep using it anyway. (cerror 'proceed nil type "LOSE")) #+franz (funcall ER%tpl) (cond (*lossage* (*throw 'lossage retval)) (t retval))) (t (cond (*lossage* (*throw 'lossage retval)) (t (abort (not (memq 'reset flags))))) retval)))))) #+lispm (defun with-stream-font-map macro (form) ;;;Example Usage: ;;; (with-stream-font-map :terminal-io (list fonts:25fr3) ;;; (print 'foo) (print 'bar)) (let ((strm (second form)) (map (third form)) (body (cdddr form))) (selfinsertmacro form `(let ((oldfnts (send ,strm ':font-map))) (unwind-protect (progn (send ,strm ':set-font-map ,map) (mapc #'eval (quote ,body)) t) (send ,strm ':set-font-map oldfnts)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;PLEASE SAVE THIS COMMENTED OUT CODE. ;;;IT IS USED IN THE TUTOR DEMO BUT NOT THE INTERPRETER. ;;;IT BELONGS IN SOME OTHER FILE HOWEVER SINCE NOBODY ;;;WANTS TO LOAD IT ROUTINELY. -- Thanks, Mark ;;; ;;;#+lispm ;;;(defun ct_logo (&optional (strm (terminal_output))) ;;; (declare (special strm)) ;;; (with-stream-font-map strm (list fonts:ct40ctc) ;;; (freshline strm) ;;; (send strm ':display-centered-string "----Computer * ahbdgfT-----") ;;; (terpri strm))) ;;; ;;; Stolen from old-demo by Mark. ;;; (See exit.lisp on lm2:>old-demo>system-windows>.) ;;; Value of *little_ada* is the actual bitarray, saved using ;;; compiler:fasd-symbol-value from old-demo's little-ada.qbin. ;;; This is loaded by compat. ;;; ;;; (defun little_ada (&optional (stream (terminal_output)) ;;; (little_ada_x 250.) ;;; (little_ada_y 250.)) ;;; (bitblt tv:alu-seta 320. 256. *little_ada* 0 0 ;;; (tv:sheet-screen-array stream) ;;; little_ada_x little_ada_y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Some functions and macros generated for Diana but ;;; seemingly of general utility. -- mlm ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; (defun truth (val) ;The Truth Function. ;;;;; ;;; Use when you want to pass any value through a predicate filter. (progn val t)) ;;;;;;; (defun falsity (val) ;The Falsity Function. ;;;;;;; ;;; Use to prevent any value from passing a predicate filter. (progn val nil)) ;;;;;;;;;;;;; (defun symbolp-check (sym fun) ;;;;;;;;;;;;; (cond ((symbolp sym) sym) (t (lose 'wta fun `("~&Datum should be a symbol: ~S~%" ,sym))))) #$. ;;;;;;;;;;;; (defun ct_atomp_int (frob) ;Internal-use-only ;;;;;;;;;;;; (or (symbolp frob) (numberp frob) (stringp frob))) #$. ;;;;;;;; (defun ct_atomp macro (form) ;;;;;;;; ;;; Like atom but does not lose with arrays. Uses care to ;;; do reasonable compile-time optimizations. (let ((frob (cadr form))) (selfinsertmacro form (cond ((or (numberp frob) (stringp frob)) (list 'quote t)) ((and (consp frob) (eq (car frob) 'quote)) `(quote ,(ct_atomp_int (cadr frob)))) ((symbolp frob) `(or (symbolp ,frob) (numberp ,frob) (stringp ,frob))) (t `(ct_atomp_int ,frob)))))) ;;;;;;;;;;;; (defun atomic-listp (frob) ;;;;;;;;;;;; ;;; Replacement for list_of_atoms_p. This one knows about arrays ;;; looking like atoms on LISPM and Franz. By atom, here, we ;;; mean the scalar datums: symbol, number, or string. (and (consp frob) (do ((x frob (cdr x))) ((not (consp x)) t) (cond ((not (ct_atomp (car x))) (return nil)))))) ;;;;;;;; (defun booleanp (frob) ;;;;;;;; (or (null frob) (eq frob t))) ;;; Special hack installed by Mark and John 10-Jan-84. This makes ;;; the lisp machine compatible with Franz in that (status feature complr) ;;; is true when the compiler is running. #+lispm (advise #+Symbolics compiler:compile-from-stream #+LMI compiler:compile-stream :around complr-feature-enable nil (let ((old-status-feature (status feature complr))) (unwind-protect (progn (unless old-status-feature (sstatus feature complr)) :do-it) (unless old-status-feature (sstatus nofeature complr))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Pre-RCS Edit History: ;;; ;;; o 6-Apr-83 Mark, John -- Many new functions, see msgs. ;;; o 26-Apr-83 Mark -- Moved ct_includef into compat. Changed hyphens. ;;; o 1-May-83 Mark -- Improved comments. ;;; o 17-May-83 Mark -- Added copytree for db translator tool. ;;; o 17-May-83 Mark -- Added DEL function for Franz. ;;; o 26-May-83 Mark -- Added LOSE stuff, RASSQ. ;;; o 26-May-83 Mark & Jim -- Commented out RASSQ, changed LOSE to call ;;; FERROR or ER%tpl after an error, added ct_load of ;;; LOOP. ;;; o 31-May-83 Mark -- Make LOSE print to *lose_stream*. Load FIXIT. ;;; o 2-Jun-83 Jim & Mark -- LOSE uses Lispm CERROR (proceedable but ;;; not restartable); returns RETVAL on Lispm ;;; o 6-Jun-83 Mark -- added with-stream-font-map macro (LM only). ;;; o 6-Jun-83 Mark -- added little_ada (LM only). ;;; ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;