home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / a / akcl2.zip / KCL-LOW.LIS next >
Lisp/Scheme  |  1992-04-16  |  14KB  |  423 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for Kyoto Common Lisp (KCL)
  28. (in-package "SI")
  29. (export '(%structure-name
  30.           %compiled-function-name
  31.           %set-compiled-function-name))
  32. (in-package 'pcl)
  33.  
  34. (shadow 'lisp:dotimes)
  35.  
  36. (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
  37.   (multiple-value-bind (doc decls bod)
  38.       (extract-declarations body env)
  39.     (declare (ignore doc))
  40.     (let ((limit (gensym))
  41.           (label (gensym)))
  42.       `(let ((,limit ,form)
  43.              (,var 0))
  44.          (declare (fixnum ,limit ,var))
  45.          ,@decls
  46.          (block nil
  47.            (tagbody
  48.             ,label
  49.               (when (>= ,var ,limit) (return-from nil ,val))
  50.               ,@bod
  51.               (setq ,var (the fixnum (1+ ,var)))
  52.               (go ,label)))))))
  53.  
  54. (defun memq (item list) (member item list :test #'eq))
  55. (defun assq (item list) (assoc item list :test #'eq))
  56. (defun posq (item list) (position item list :test #'eq))
  57.  
  58. (si:define-compiler-macro memq (item list) 
  59.   (let ((var (gensym)))
  60.     (once-only (item)
  61.       `(let ((,var ,list))
  62.          (loop (unless ,var (return nil))
  63.                (when (eq ,item (car ,var))
  64.                  (return ,var))
  65.                (setq ,var (cdr ,var)))))))
  66.  
  67. (si:define-compiler-macro assq (item list) 
  68.   (let ((var (gensym)))
  69.     (once-only (item)
  70.       `(dolist (,var ,list nil)
  71.          (when (eq ,item (car ,var))
  72.            (return ,var))))))
  73.  
  74. (si:define-compiler-macro posq (item list) 
  75.   (let ((var (gensym)) (index (gensym)))
  76.     (once-only (item)
  77.       `(let ((,var ,list) (,index 0))
  78.          (declare (fixnum ,index))
  79.          (dolist (,var ,list nil)
  80.            (when (eq ,item ,var)
  81.              (return ,index))
  82.            (incf ,index))))))
  83.  
  84. (defun printing-random-thing-internal (thing stream)
  85.   (format stream "~O" (si:address thing)))
  86.  
  87.  
  88. #+akcl
  89. (eval-when (load compile eval)
  90.  
  91. ;compiler::*compile-ordinaries* is set to t in kcl-patches
  92.  
  93. (if (and (boundp 'si::*akcl-version*)
  94.      (>= si::*akcl-version* 604))
  95.     (progn
  96.       (pushnew :turbo-closure *features*)
  97.       (pushnew :turbo-closure-env-size *features*))
  98.     (when (fboundp 'si::allocate-growth) 
  99.       (pushnew :turbo-closure *features*)))
  100.  
  101. ;; patch around compiler bug.
  102. (when (<= si::*akcl-version* 609)
  103. (defvar dit-it nil)
  104.  (when (null dit-it)
  105.    (setq compiler::*cmpinclude-string*
  106.      (concatenate 'string "static int Vcs;
  107. " compiler::*cmpinclude-string*))
  108.    )
  109.  (setq did-it t)
  110.  
  111. (setq compiler::*type-alist*
  112.       (delete (assoc 'ratio compiler::*type-alist*)
  113.           compiler::*type-alist*))
  114. ) ;end <=609
  115.  
  116. )
  117.  
  118. (defmacro %svref (vector index)
  119.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  120.  
  121. (defsetf %svref (vector index) (new-value)
  122.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  123.          ,new-value))
  124.  
  125.  
  126. ;;;
  127. ;;; std-instance-p
  128. ;;;
  129. #-akcl
  130. (si:define-compiler-macro std-instance-p (x)
  131.   (once-only (x)
  132.     `(and (si:structurep ,x)
  133.           (eq (si:%structure-name ,x) 'std-instance))))
  134.  
  135. #+akcl
  136. (progn
  137.  
  138. ;; declare that std-instance-p may be computed simply, and will not change.
  139. (si::freeze-defstruct 'pcl::std-instance)
  140.  
  141.  
  142. (defvar *pcl-funcall*  '(lambda (loc)
  143.           (compiler::wt-nl
  144.            "{object _funobj = " loc ";"
  145.            "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo))
  146.                    (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo);
  147.                else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))();
  148.                else super_funcall_no_event(_funobj);}")))
  149. (setq compiler::*super-funcall* *pcl-funcall*)
  150.  
  151. )
  152.  
  153. (defun pcl::proclaim-defmethod (x y) y
  154.   (and (symbolp x)
  155.        (setf (get x 'compiler::proclaimed-closure ) t)))
  156.  
  157.  
  158. ;;;
  159. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  160. ;;;
  161. #-turbo-closure-env-size
  162. (clines "
  163. object cclosure_env_nthcdr (n,cc)
  164. int n; object cc;
  165. {  object env;
  166.    if(n<0)return Cnil;
  167.    if(type_of(cc)!=t_cclosure)return Cnil;
  168.    env=cc->cc.cc_env;
  169.    while(n-->0)
  170.      {if(type_of(env)!=t_cons)return Cnil;
  171.       env=env->c.c_cdr;}
  172.    return env;
  173. }")
  174.  
  175. #+turbo-closure-env-size
  176. (clines "
  177. object cclosure_env_nthcdr (n,cc)
  178. int n; object cc;
  179. {  object env,*turbo;
  180.    if(n<0)return Cnil;
  181.    if(type_of(cc)!=t_cclosure)return Cnil;
  182.    if((turbo=cc->cc.cc_turbo)==NULL)
  183.      {env=cc->cc.cc_env;
  184.       while(n-->0)
  185.         {if(type_of(env)!=t_cons)return Cnil;
  186.          env=env->c.c_cdr;}
  187.       return env;}
  188.    else
  189.      {if(n>=fix(*(turbo-1)))return Cnil;
  190.       return turbo[n];}
  191. }")
  192.  
  193. ;; This is the completely safe version.
  194. (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
  195. ;; This is the unsafe but fast version.
  196. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
  197.  
  198. ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
  199. (eval-when (compile load eval)
  200.  
  201. ;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
  202. (defparameter *kcl-function-inlines*
  203.   '(#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
  204.     #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
  205.     #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
  206.     (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
  207.     (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
  208.     (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
  209.     (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
  210.     (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
  211.     #+turbo-closure
  212.     (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
  213.     
  214.     (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
  215.   
  216. (defun make-function-inline (inline)
  217.   (setf (get (car inline) 'compiler::inline-always)
  218.         (list (if (fboundp 'compiler::flags)
  219.                   (let ((opt (cdr inline)))
  220.                     (list (first opt) (second opt)
  221.                           (logior (if (fourth opt) 1 0) ; allocates-new-storage
  222.                                   (if (third opt) 2 0)  ; side-effect
  223.                                   (if nil 4 0) ; constantp
  224.                                   (if (eq (car inline) 'logxor)
  225.                                       8 0)) ;result type from args
  226.                           (fifth opt)))
  227.                   (cdr inline)))))
  228.  
  229. (defmacro define-inlines ()
  230.   `(progn
  231.     ,@(mapcan #'(lambda (inline)
  232.                   (let ((name (intern (format nil "~S inline" (car inline))))
  233.                         (vars (mapcar #'(lambda (type)
  234.                                           (declare (ignore type))
  235.                                           (gensym))
  236.                                       (cadr inline))))
  237.                     `((make-function-inline ',(cons name (cdr inline)))
  238.                       ,@(when (or (every #'(lambda (type) (eq type 't))
  239.                                          (cadr inline))
  240.                                   (char= #\% (aref (symbol-name (car inline)) 0)))
  241.                           `((defun ,(car inline) ,vars
  242.                               ,@(mapcan #'(lambda (var var-type)
  243.                                             (unless (eq var-type 't)
  244.                                               `((declare (type ,var-type ,var)))))
  245.                                         vars (cadr inline))
  246.                               (,name ,@vars))
  247.                             (make-function-inline ',inline))))))
  248.               *kcl-function-inlines*)))
  249.  
  250. (define-inlines)
  251. )
  252.  
  253. (defsetf si:%compiled-function-name si:%set-compiled-function-name)
  254. (defsetf %cclosure-env %set-cclosure-env)
  255.  
  256. (defun set-function-name-1 (fn new-name ignore)
  257.   (declare (ignore ignore))
  258.   (cond ((compiled-function-p fn)
  259.      (si::turbo-closure fn)
  260.      (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil))
  261.          (setf (si:%compiled-function-name fn) new-name))
  262.         ((and (listp fn)
  263.               (eq (car fn) 'lambda-block))
  264.          (setf (cadr fn) new-name))
  265.         ((and (listp fn)
  266.               (eq (car fn) 'lambda))
  267.          (setf (car fn) 'lambda-block
  268.                (cdr fn) (cons new-name (cdr fn)))))
  269.   fn)
  270.  
  271.  
  272. #+akcl (clines "#define AKCL206") 
  273.  
  274. (clines "
  275. #ifdef AKCL206
  276. use_fast_links();
  277. #endif
  278.  
  279. object set_cclosure (result_cc,value_cc,available_size)
  280.   object result_cc,value_cc; int available_size;
  281. {
  282.   object result_env_tail,value_env_tail; int i;
  283. #ifdef AKCL206
  284.   /* If we are currently using fast linking,     */
  285.   /* make sure to remove the link for result_cc. */
  286.   use_fast_links(3,Cnil,result_cc);
  287. #endif
  288.   result_env_tail=result_cc->cc.cc_env;
  289.   value_env_tail=value_cc->cc.cc_env;
  290.   for(i=available_size;
  291.       result_env_tail!=Cnil && i>0;
  292.       result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))
  293.     CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;
  294.   result_cc->cc.cc_self=value_cc->cc.cc_self;
  295.   result_cc->cc.cc_data=value_cc->cc.cc_data;
  296. #ifndef AKCL206
  297.   result_cc->cc.cc_start=value_cc->cc.cc_start;
  298.   result_cc->cc.cc_size=value_cc->cc.cc_size;
  299. #endif
  300.   return result_cc;
  301. }")
  302.  
  303. (defentry %set-cclosure (object object int) (object set_cclosure))
  304.  
  305.  
  306. (defun structure-functions-exist-p ()
  307.   t)
  308.  
  309. (si:define-compiler-macro structure-instance-p (x)
  310.   (once-only (x)
  311.     `(and (si:structurep ,x)
  312.           (not (eq (si:%structure-name ,x) 'std-instance)))))
  313.  
  314. (defun structure-type (x)
  315.   (and (si:structurep x)
  316.        (si:%structure-name x)))
  317.  
  318. (si:define-compiler-macro structure-type (x)
  319.   (once-only (x)
  320.     `(and (si:structurep ,x)
  321.           (si:%structure-name ,x))))
  322.  
  323. (defun structure-type-p (type)
  324.   (or (not (null (gethash type *structure-table*)))
  325.       (let (#+akcl(s-data nil))
  326.         (and (symbolp type)
  327.              #+akcl (setq s-data (get type 'si::s-data))
  328.              #-akcl (get type 'si::is-a-structure)
  329.              (null #+akcl (si::s-data-type s-data)
  330.                    #-akcl (get type 'si::structure-type))))))
  331.  
  332. (defun structure-type-included-type-name (type)
  333.   (or (car (gethash type *structure-table*))
  334.       #+akcl (si::s-data-included (get type 'si::s-data))
  335.       #-akcl (get type 'si::structure-include)))
  336.  
  337. (defun structure-type-internal-slotds (type)
  338.   #+akcl (si::s-data-slot-descriptions (get type 'si::s-data))
  339.   #-akcl (get type 'si::structure-slot-descriptions))
  340.  
  341. (defun structure-type-slot-description-list (type)
  342.   (or (cdr (gethash type *structure-table*))
  343.       (mapcan #'(lambda (slotd)
  344.                   (when (and slotd (car slotd))
  345.                     (let ((offset (fifth slotd)))
  346.                       (let ((reader #'(lambda (x)
  347.                                         #+akcl (si:structure-ref1 x offset)
  348.                                         #-akcl (si:structure-ref x type offset)))
  349.                             (writer #'(lambda (v x)
  350.                                         (si:structure-set x type offset v))))
  351.                         #+turbo-closure (si:turbo-closure reader)
  352.                         #+turbo-closure (si:turbo-closure writer)
  353.                         (let* ((reader-sym 
  354.                 (let ((*package* *the-pcl-package*))
  355.                   (intern (format nil "~s SLOT~D" type offset))))
  356.                    (writer-sym (get-setf-function-name reader-sym))
  357.                    (slot-name (first slotd))
  358.                    (read-only-p (fourth slotd)))
  359.                           (setf (symbol-function reader-sym) reader)
  360.                           (setf (symbol-function writer-sym) writer)
  361.                           (do-standard-defsetf-1 reader-sym)
  362.                           (list (list slot-name
  363.                                       reader-sym
  364.                                       (and (not read-only-p) writer))))))))
  365.               (let ((slotds (structure-type-internal-slotds type))
  366.                     (inc (structure-type-included-type-name type)))
  367.                 (if inc
  368.                     (nthcdr (length (structure-type-internal-slotds inc))
  369.                             slotds)
  370.                     slotds)))))
  371.             
  372.  
  373. (defun structure-slotd-name (slotd)
  374.   (first slotd))
  375.  
  376. (defun structure-slotd-accessor-symbol (slotd)
  377.   (second slotd))
  378.  
  379. (defun structure-slotd-writer-function (slotd)
  380.   (third slotd))
  381.  
  382. ;; Construct files sys-proclaim.lisp and sys-package.lisp
  383. ;; The file sys-package.lisp must be loaded first, since the
  384. ;; package sys-proclaim.lisp will refer to symbols and they must
  385. ;; be in the right packages.   sys-proclaim.lisp contains function
  386. ;; declarations and declarations that certain things are closures.
  387.  
  388. (defun renew-sys-files()
  389.   ;; packages:
  390.   (compiler::get-packages "sys-package.lisp")
  391.   (with-open-file (st "sys-package.lisp"
  392.               :direction :output
  393.               :if-exists :append)
  394.     (format st "(in-package 'SI)
  395. (export '(%structure-name
  396.           %compiled-function-name
  397.           %set-compiled-function-name))
  398. (in-package 'pcl)
  399. "))
  400.  
  401.   ;; proclaims
  402.   (compiler::make-all-proclaims "*.fn")
  403.   (with-open-file (st "sys-proclaim.lisp"
  404.               :direction :output
  405.               :if-exists :append)
  406.     (format st "~%(IN-PACKAGE \"PCL\")~%")
  407.     (print
  408.      `(dolist (v ',
  409.      
  410.            (sloop::sloop for v in-package "PCL"
  411.                  when (get v 'compiler::proclaimed-closure)
  412.                  collect v))
  413.     (setf (get v 'compiler::proclaimed-closure) t))
  414.      st)
  415.     (format st "~%")
  416. ))
  417.  
  418.     
  419.          
  420.               
  421.   
  422.  
  423.