home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpfun.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  30.6 KB  |  957 lines
  1. ;; CMPFUN  Library functions.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'princ 'c1princ 'c1)
  25. (si:putprop 'princ 'c2princ 'c2)
  26. (si:putprop 'terpri 'c1terpri 'c1)
  27.  
  28. (si:putprop 'apply 'c1apply 'c1)
  29. (si:putprop 'apply 'c2apply 'c2)
  30. (si:putprop 'apply-optimize 'c2apply-optimize 'c2)
  31. (si:putprop 'funcall 'c1funcall 'c1)
  32.  
  33. (si:putprop 'rplaca 'c1rplaca 'c1)
  34. (si:putprop 'rplaca 'c2rplaca 'c2)
  35. (si:putprop 'rplacd 'c1rplacd 'c1)
  36. (si:putprop 'rplacd 'c2rplacd 'c2)
  37.  
  38. (si:putprop 'si::memq 'c1memq 'c1)
  39. (si:putprop 'member 'c1member 'c1)
  40. (si:putprop 'member!2 'c2member!2 'c2)
  41. (si:putprop 'assoc 'c1assoc 'c1)
  42. (si:putprop 'assoc!2 'c2assoc!2 'c2)
  43. (si:putprop 'get 'c1get 'c1)
  44. (si:putprop 'get 'c2get 'c2)
  45.  
  46. (si:putprop 'nth '(c1nth-condition . c1nth) 'c1conditional)
  47. (si:putprop 'nthcdr '(c1nthcdr-condition . c1nthcdr) 'c1conditional)
  48. (si:putprop 'si:rplaca-nthcdr 'c1rplaca-nthcdr 'c1)
  49. (si:putprop 'si:list-nth 'c1list-nth 'c1)
  50. (si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2)
  51.  
  52. (defvar *princ-string-limit* 80)
  53.  
  54. (defun c1princ (args &aux stream (info (make-info)))
  55.   (when (endp args) (too-few-args 'princ 1 0))
  56.   (unless (or (endp (cdr args)) (endp (cddr args)))
  57.           (too-many-args 'princ 2 (length args)))
  58.   (setq stream (if (endp (cdr args))
  59.                    (c1nil)
  60.                    (c1expr* (cadr args) info)))
  61.   (if (and (or (and (stringp (car args))
  62.                     (<= (length (car args)) *princ-string-limit*))
  63.                (characterp (car args)))
  64.            (or (endp (cdr args))
  65.                (and (eq (car stream) 'var)
  66.                     (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL)))))
  67.       (list 'princ info (car args)
  68.             (if (endp (cdr args)) nil (var-loc (caaddr stream)))
  69.             stream)
  70.       (list 'call-global info 'princ
  71.             (list (c1expr* (car args) info) stream))))
  72.  
  73. (defun c2princ (string vv-index stream)
  74.   (cond ((eq *value-to-go* 'trash)
  75.          (cond ((characterp string)
  76.                 (wt-nl "princ_char(" (char-code string))
  77.                 (if (null vv-index) (wt ",Cnil") (wt ",VV[" vv-index "]"))
  78.                 (wt ");"))
  79.                ((= (length string) 1)
  80.                 (wt-nl "princ_char(" (char-code (aref string 0)))
  81.                 (if (null vv-index) (wt ",Cnil") (wt ",VV[" vv-index "]"))
  82.                 (wt ");"))
  83.                (t
  84.                 (wt-nl "princ_str(\"")
  85.                 (dotimes** (n (length string))
  86.                   (let ((char (schar string n)))
  87.                        (cond ((char= char #\\) (wt "\\\\"))
  88.                              ((char= char #\") (wt "\\\""))
  89.                              ((char= char #\Newline) (wt "\\n"))
  90.                              (t (wt char)))))
  91.                 (wt "\",")
  92.                 (if (null vv-index) (wt "Cnil") (wt "VV[" vv-index "]"))
  93.                 (wt ");")))
  94.          (unwind-exit nil))
  95.         ((eql string #\Newline) (c2call-global 'terpri (list stream) nil t))
  96.         (t (c2call-global
  97.             'princ
  98.             (list (list 'LOCATION
  99.                         (make-info :type
  100.                           (if (characterp string) 'character 'string))
  101.                         (list 'VV (add-object string)))
  102.                   stream) nil t))))
  103.  
  104. (defun c1terpri (args &aux stream (info (make-info)))
  105.   (unless (or (endp args) (endp (cdr args)))
  106.           (too-many-args 'terpri 1 (length args)))
  107.   (setq stream (if (endp args)
  108.                    (c1nil)
  109.                    (c1expr* (car args) info)))
  110.   (if (or (endp args)
  111.           (and (eq (car stream) 'var)
  112.                (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL))))
  113.       (list 'princ info #\Newline
  114.             (if (endp args) nil (var-loc (caaddr stream)))
  115.             stream)
  116.       (list 'call-global info 'terpri (list stream))))
  117.  
  118. (defun c1apply (args &aux info)
  119.   (when (or (endp args) (endp (cdr args)))
  120.         (too-few-args 'apply 2 (length args)))
  121.   (let ((funob (c1funob (car args))))
  122.        (setq info (copy-info (cadr funob)))
  123.        (setq args (c1args (cdr args) info))
  124.        (cond ((eq (car funob) 'call-lambda)
  125.               (let* ((lambda-expr (caddr funob))
  126.                      (lambda-list (caddr lambda-expr)))
  127.                     (declare (object lambda-expr lambda-list))
  128.                     (if (and (null (cadr lambda-list))        ; No optional
  129.                              (null (cadddr lambda-list)))    ; No keyword
  130.                         (c1apply-optimize info
  131.                                           (car lambda-list)
  132.                                           (caddr lambda-list)
  133.                                           (car (cddddr lambda-expr))
  134.                                           args)
  135.                        (list 'apply info funob args))))
  136.              (t (list 'apply info funob args))))
  137.   )
  138.  
  139. (defun c2apply (funob args &aux (*vs* *vs*) loc)
  140.   (setq loc (save-funob funob))
  141.   (let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar))))
  142.        (do ((l args (cdr l)))
  143.            ((endp (cdr l))
  144.             (wt-nl "{object " last-arg ";")
  145.             (let ((*value-to-go* last-arg)) (c2expr* (car l))))
  146.            (declare (object l))
  147.            (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car l))))
  148.        (wt-nl " vs_top=base+" *vs* ";")
  149.        (base-used)
  150.        (cond (*safe-compile*
  151.               (wt-nl " while(!endp(" last-arg "))")
  152.               (wt-nl " {vs_push(car(" last-arg "));")
  153.               (wt last-arg "=cdr(" last-arg ");}"))
  154.              (t
  155.               (wt-nl " while(" last-arg "!=Cnil)")
  156.               (wt-nl " {vs_push((" last-arg ")->c.c_car);")
  157.               (wt last-arg "=(" last-arg ")->c.c_cdr;}")))
  158.        (wt-nl "vs_base=base+" base ";}")
  159.        (base-used))
  160.   (c2funcall funob 'args-pushed loc)
  161.   )
  162.  
  163. (defun c1apply-optimize (info requireds rest body args
  164.                               &aux (vl nil) (fl nil))
  165.   (do ()
  166.       ((or (endp (cdr args)) (endp requireds)))
  167.       (push (pop requireds) vl)
  168.       (push (pop args) fl))
  169.  
  170.   (cond ((cdr args)    ;;; REQUIREDS is NIL.
  171.          (cmpck (null rest)
  172.                 "APPLY passes too many arguments to LAMBDA expression.")
  173.          (push rest vl)
  174.          (push (list 'call-global info 'list* args) fl)
  175.          (list 'let info (reverse vl) (reverse fl) body))
  176.         (requireds    ;;; ARGS is singleton.
  177.          (let ((temp (make-var :kind 'LEXICAL :ref t)))
  178.               (push temp vl)
  179.               (push (car args) fl)
  180.               (list 'let info (reverse vl) (reverse fl)
  181.                     (list 'apply-optimize
  182.                           (cadr body) temp requireds rest body))))
  183.         (rest (push rest vl)
  184.               (push (car args) fl)
  185.               (list 'let info (reverse vl) (reverse fl) body))
  186.         (t
  187.          (let ((temp (make-var :kind 'LEXICAL :ref t)))
  188.               (push temp vl)
  189.               (push (car args) fl)
  190.               (list 'let info (reverse vl) (reverse fl)
  191.                     (list 'apply-optimize
  192.                           (cadr body) temp requireds rest body))))
  193.         )
  194.   )
  195.  
  196. (defun c2apply-optimize (temp requireds rest body
  197.                               &aux (*unwind-exit* *unwind-exit*) (*vs* *vs*)
  198.                                    (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  199.   (when (or *safe-compile* *compiler-check-args*)
  200.         (wt-nl (if rest "ck_larg_at_least" "ck_larg_exactly")
  201.                 "(" (length requireds) ",")
  202.         (wt-var temp nil)
  203.         (wt ");"))
  204.  
  205.   (dolist** (v requireds) (setf (var-ref v) (vs-push)))
  206.   (when rest (setf (var-ref rest) (vs-push)))
  207.  
  208.   (do ((n 0 (1+ n))
  209.        (vl requireds (cdr vl)))
  210.       ((endp vl)
  211.        (when rest
  212.              (wt-nl) (wt-vs (var-ref rest)) (wt "= ")
  213.              (dotimes** (i n) (wt "("))
  214.              (wt-var temp nil)
  215.              (dotimes** (i n) (wt-nl ")->c.c_cdr"))
  216.              (wt ";")))
  217.       (declare (fixnum n) (object vl))
  218.       (wt-nl) (wt-vs (var-ref (car vl))) (wt "=(")
  219.       (dotimes** (i n) (wt "("))
  220.       (wt-var temp nil)
  221.       (dotimes** (i n) (wt-nl ")->c.c_cdr"))
  222.       (wt ")->c.c_car;"))
  223.  
  224.   (dolist** (var requireds) (c2bind var))
  225.   (when rest (c2bind rest))
  226.  
  227.   (c2expr body)
  228.   )
  229.  
  230. (defun c1funcall (args &aux funob (info (make-info)))
  231.   (when (endp args) (too-few-args 'funcall 1 0))
  232.   (setq funob (c1funob (car args)))
  233.   (add-info info (cadr funob))
  234.   (list 'funcall info funob (c1args (cdr args) info))
  235.   )
  236.  
  237.  
  238. (defun c1rplaca (args &aux (info (make-info)))
  239.   (when (or (endp args) (endp (cdr args)))
  240.         (too-few-args 'rplaca 2 (length args)))
  241.   (unless (endp (cddr args))
  242.           (too-many-args 'rplaca 2 (length args)))
  243.   (setq args (c1args args info))
  244.   (list 'rplaca info args))
  245.  
  246. (defun c2rplaca (args &aux (*vs* *vs*) (*inline-blocks* 0))
  247.   (setq args (inline-args args '(t t)))
  248.   (safe-compile
  249.    (wt-nl "if(type_of(" (car args) ")!=t_cons)"
  250.           "FEwrong_type_argument(Scons," (car args) ");"))
  251.   (wt-nl "(" (car args) ")->c.c_car = " (cadr args) ";")
  252.   (unwind-exit (car args))
  253.   (close-inline-blocks)
  254.   )
  255.  
  256. (defun c1rplacd (args &aux (info (make-info)))
  257.   (when (or (endp args) (endp (cdr args)))
  258.         (too-few-args 'rplacd 2 (length args)))
  259.   (when (not (endp (cddr args)))
  260.         (too-many-args 'rplacd 2 (length args)))
  261.   (setq args (c1args args info))
  262.   (list 'rplacd info args))
  263.  
  264. (defun c2rplacd (args &aux (*vs* *vs*) (*inline-blocks* 0))
  265.   (setq args (inline-args args '(t t)))
  266.   (safe-compile
  267.    (wt-nl "if(type_of(" (car args) ")!=t_cons)"
  268.           "FEwrong_type_argument(Scons," (car args) ");"))
  269.   (wt-nl "(" (car args) ")->c.c_cdr = " (cadr args) ";")
  270.   (unwind-exit (car args))
  271.   (close-inline-blocks)
  272.   )
  273.  
  274. (defun c1memq (args &aux (info (make-info)))
  275.   (when (or (endp args) (endp (cdr args)))
  276.         (too-few-args 'si::memq 2 (length args)))
  277.   (unless (endp (cddr args))
  278.           (too-many-args 'si::memq 2 (length args)))
  279.   (list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info)))
  280.         
  281. (defun c1member (args &aux (info (make-info)))
  282.   (when (or (endp args) (endp (cdr args)))
  283.         (too-few-args 'member 2 (length args)))
  284.   (cond ((endp (cddr args))
  285.          (list 'member!2 info 'eql (c1args args info)))
  286.         ((and (eq (caddr args) :test)
  287.               (eql (length args) 4)    
  288.        (member  (cadddr args) '('eq #'eq 'equal #'equal
  289.                 'equalp #'equalp 'eql #'eql)
  290.         :test 'equal))
  291.          (list 'member!2 info (cadr (cadddr args))
  292.                (c1args (list (car args) (cadr args)) info)))
  293.         (t
  294.          (list 'call-global info 'member (c1args args info)))))
  295.  
  296. (defun c2member!2 (fun args
  297.                        &aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar)))
  298.   (setq args (inline-args args '(t t)))
  299.   (wt-nl "{register object x= " (car args) ",V" l "= " (cadr args) ";")
  300.   (if *safe-compile*
  301.       (wt-nl "while(!endp(V" l "))")
  302.       (wt-nl "while(V" l "!=Cnil)"))
  303.   (if (eq fun 'eq)
  304.       (wt-nl "if(x==(V" l "->c.c_car)){")
  305.       (wt-nl "if(" (string-downcase (symbol-name fun))
  306.         "(x,V" l "->c.c_car)){"))
  307.   (if (and (consp *value-to-go*)
  308.            (or (eq (car *value-to-go*) 'JUMP-TRUE)
  309.                (eq (car *value-to-go*) 'JUMP-FALSE)))
  310.       (unwind-exit t 'JUMP)
  311.       (unwind-exit (list 'CVAR l) 'JUMP))
  312.   (wt-nl "}else V" l "=V" l "->c.c_cdr;")
  313.   (unwind-exit nil)
  314.   (wt "}")
  315.   (close-inline-blocks)
  316.   )
  317.  
  318. (defun c1assoc (args &aux (info (make-info)))
  319.   (when (or (endp args) (endp (cdr args)))
  320.         (too-few-args 'assoc 2 (length args)))
  321.   (cond ((endp (cddr args))
  322.          (list 'assoc!2 info 'eql (c1args args info)))
  323.         ((and (eq (caddr args) ':test)
  324.               (eql (length args) 4)    
  325.        (member  (cadddr args) '('eq #'eq 'equal #'equal
  326.                 'equalp #'equalp 'eql #'eql)
  327.         :test 'equal))
  328.          (list 'assoc!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info)))
  329.         (t
  330.          (list 'call-global info 'assoc (c1args args info)))))
  331.  
  332. (defun c2assoc!2 (fun args
  333.                       &aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar))name)
  334.   (setq args (inline-args args '(t t)))
  335.   (setq name (symbol-name fun))
  336.   (or (eq fun 'eq) (setq name (string-downcase name)))
  337.   (wt-nl "{register object x= " (car args) ",V" al "= " (cadr args) ";")
  338.   (cond (*safe-compile*
  339.          (wt-nl "while(!endp(V" al "))")
  340.              (wt-nl "if(type_of(V"al"->c.c_car)==t_cons &&"
  341.             name "(x,V" al "->c.c_car->c.c_car)){"))
  342.         (t
  343.          (wt-nl "while(V" al "!=Cnil)")
  344.              (wt-nl "if(" name "(x,V" al "->c.c_car->c.c_car) &&"
  345.             "V"al"->c.c_car != Cnil){"))) 
  346.   (if (and (consp *value-to-go*)
  347.            (or (eq (car *value-to-go*) 'jump-true)
  348.                (eq (car *value-to-go*) 'jump-false)))
  349.       (unwind-exit t 'jump)
  350.       (unwind-exit (list 'CAR al) 'jump))
  351.   (wt-nl "}else V" al "=V" al "->c.c_cdr;")
  352.   (unwind-exit nil)
  353.   (wt "}")
  354.   (close-inline-blocks)
  355.   )
  356.  
  357.  
  358.  
  359.  
  360. ;(defun boole3 (a b c)  (boole a b c))
  361. (si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional)
  362.  
  363. (defun c1boole-condition (args)
  364.    (and (not (endp (cddr args)))
  365.     (endp (cdddr args))
  366.         (inline-boole3-string (car args))))
  367.  
  368. (defun c1boole3 (args)
  369.   (c1expr (cons 'boole3 args)))
  370.  
  371. (defun inline-boole3 (&rest args)
  372.   (let ((boole-op-arg (second (car args))))
  373.     (or (eq (car boole-op-arg) 'fixnum-value) (error "must be constant"))
  374.     (let ((string (inline-boole3-string  (third boole-op-arg))))
  375.       (or string (error "should not get here boole opt"))
  376.       (wt-inline-loc string (cdr args)))))
  377.  
  378. (defun inline-boole3-string (op-code)
  379.   (and (constantp op-code) (setq op-code (eval op-code)))
  380.   (case op-code
  381.     (#. boole-andc1 "((~(#0))&(#1))")
  382.     (#. boole-andc2 "(((#0))&(~(#1)))")
  383.     (#. boole-nor   "(~((#0)|(#1)))")
  384.     (#. boole-orc1  "(~(#0)) | (#1)))")
  385.     (#. boole-orc2  "((#0) | (~(#1)))")
  386.     (#. boole-nand "(~((#0) & (#1)))")
  387.     (#. boole-eqv    "(~((#0) ^ (#1)))")
  388.     (#. boole-and "((#0) & (#1))")
  389.     (#. boole-xor "((#0) ^ (#1))")
  390.     (#. boole-ior "((#0) | (#1))")))
  391.  
  392. (si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional)
  393.  
  394. (defun c1ash-condition (args)
  395.   (let ((shamt (second args)))
  396.     (or (typep shamt '(integer 0 31))
  397.     (and (consp shamt)
  398.          (eq (car  shamt) 'the)
  399.          (let ((type (cadr  shamt)))
  400.             (subtypep type '(integer 0 31)))))))
  401.  
  402. (defun c1ash (args)
  403.   (let  ((shamt (second args))fun)
  404.     (cond ((constantp shamt) (setq shamt (eval shamt))
  405.        (or (si:fixnump shamt) (error "integer shift only"))
  406.        (cond ((< shamt 0) (setq fun 'shift>> ))
  407.          ((>= shamt 0) (setq fun 'shift<<))))
  408.       (t (let ((type (second shamt)))
  409.            ;;it had to be a (the type..)
  410.            (cond ((subtypep type '(integer 0 31))
  411.               (setq fun 'shift<< ))
  412.              ((subtypep type '(integer -31 0))
  413.               (setq fun 'shift>> ))
  414.              (t (error "should not get here")))
  415.            )))
  416.     (c1expr (cons fun args))))
  417. (defun shift>> (a b) (ash a  b))
  418. (defun shift<< (a b) (ash a  b))
  419. (si:putprop 'ash '(c1ash-condition . c1ash)  'c1conditional)
  420. (si:putprop 'shift>> "Lash" 'lfun)
  421. (si:putprop 'shift<< "Lash" 'lfun)
  422.  
  423. (si::putprop 'ldb 'co1ldb 'co1)            
  424.  
  425. (defun co1ldb (f args &aux tem (len (integer-length most-positive-fixnum))) f
  426.   (let ((specs
  427.      (cond ((and (consp (setq tem (first args)))
  428.              (eq 'byte (car tem))
  429.              (cons (second tem) (third tem)))))))
  430.     (cond ((and (integerp (cdr specs))
  431.         (integerp (car specs))
  432.         (< (+ (car specs)(cdr specs))
  433.            len)
  434.         (subtypep (result-type (second args)) 'fixnum))
  435.        (c1expr `(the fixnum (ldb1 ,(car specs) ,(cdr specs) ,(second args))))))))
  436.  
  437.       
  438. (si:putprop 'length 'c1length 'c1)
  439.  
  440. (defun c1length (args &aux (info (make-info)))
  441.   (setf (info-type info) 'fixnum)
  442.   (cond ((and (consp (car args))
  443.           (eq (caar args) 'symbol-name)
  444.           (let ((args1 (cdr (car args))))
  445.         (and args1 (not (cddr args1))
  446.              (list 'call-global info 'symbol-length
  447.                (c1args args1 info))))))
  448.     (t  (setq args (c1args args info))
  449.         (list 'call-global info 'length args ))))
  450.  
  451.  
  452. (defun c1get (args &aux (info (make-info)))
  453.  
  454.   (when (or (endp args) (endp (cdr args)))
  455.         (too-few-args 'get 2 (length args)))
  456.   (when (and (not (endp (cddr args))) (not (endp (cdddr args))))
  457.         (too-many-args 'get 3 (length args)))
  458.   (list 'get info (c1args args info)))
  459.  
  460. (defun c2get (args)
  461.   (if *safe-compile*
  462.       (c2call-global 'get args nil t)
  463.       (let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar)))
  464.            (setq args (inline-args args (if (cddr args) '(t t t) '(t t))))
  465.            (wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;")
  466.            (wt-nl " object ind= " (cadr args) ";")
  467.            (wt-nl "while(V" pl "!=Cnil){")
  468.            (wt-nl "if(V" pl "->c.c_car==ind){")
  469.            (unwind-exit (list 'CADR pl) 'jump)
  470.            (wt-nl "}else V" pl "=V" pl "->c.c_cdr->c.c_cdr;}")
  471.            (unwind-exit (if (cddr args) (caddr args) nil))
  472.            (wt "}")
  473.            (close-inline-blocks)))
  474.   )
  475.  
  476. (defun co1eql (f args) f
  477.   (or (and (cdr args) (not *safe-compile*))
  478.       (return-from co1eql nil))
  479.   (cond ((replace-constant args)
  480.      (cond ((characterp (second args))
  481.         (setq args (reverse args))))
  482.      (cond ((characterp (car args))
  483.         (let ((c (gensym)))
  484.           (c1expr
  485.            `(let ((,c ,(second args)))
  486.               (declare (type ,(result-type (second args))
  487.                      ,c))
  488.               (and (typep ,c 'character)
  489.                (= (char-code ,(car args))
  490.                   (the fixnum
  491.                    (char-code
  492.                     (the character
  493.                      ,c)))
  494.                   ))))))))))
  495.  
  496.  
  497.      
  498. (si::putprop 'eql 'co1eql 'co1)            
  499.  
  500. (defvar *frozen-defstructs* nil)
  501.  
  502. ;; Return the most particular type we can EASILY obtain
  503. ;; from x.  
  504. (defun result-type (x)
  505.   (cond ((symbolp x)
  506.      (let ((tem (c1expr x)))
  507.        (info-type (second tem))))
  508.     ((constantp x)
  509.      (type-filter (type-of x)))
  510.     ((and (consp x) (eq (car x) 'the))
  511.      (type-filter (second x)))
  512.     (t t)))
  513.  
  514.  
  515.  
  516. (defvar *type-alist*
  517.   '((fixnum . si::fixnump)
  518.     (float . floatp)
  519.     (short-float . short-float-p)
  520.     (long-float . long-float-p)
  521.     (integer . integerp)
  522.     (character . characterp)
  523.     (symbol . symbolp)
  524.     (cons . consp)
  525.     (null . null)
  526.     (array . arrayp)
  527.     (vector . vectorp)
  528.     (bit-vector . bit-vector-p)
  529.     (string . stringp)
  530.     (list . (lambda (y) (or (consp y) (null y))))
  531.     (number . numberp)
  532.     (rational . rationalp)
  533.     (complex . complexp)
  534.     (ratio . ratiop)
  535.     (sequence . (lambda (y) (or (listp y) (vectorp y))))
  536.     (function . functionp)
  537.     ))
  538.  
  539.  
  540. (defun co1typep (f args &aux tem) f
  541.   (let*
  542.       ((x (car args))  new
  543.        (type (and (consp (second args))
  544.           (eq (car (second args)) 'quote)
  545.           (second (second args)))))
  546.     (cond ((subtypep (result-type (car args)) type)
  547.        (setq new t)
  548.        (return-from co1typep (c1expr new))))
  549.     (setq new
  550.       (cond
  551.        ((null type) nil)
  552.        ((setq f (assoc type *type-alist* :test 'equal))
  553.         (list (cdr f) x))
  554.        ((and (consp type)
  555.          (or (and (eq (car type) 'vector)
  556.               (null (cddr type)))
  557.              (and 
  558.               (member (car type)
  559.                   '(array vector simple-array))
  560.               (equal (third type) '(*)))))
  561.         (setq tem (si::best-array-element-type
  562.                (second type)))
  563.         (cond ((eq tem 'string-char) `(stringp ,x))
  564.           ((eq tem 'bit) `(bit-vector-p ,x))
  565.           ((setq tem (position tem *aet-types*))
  566.            `(the boolean (vector-type ,x ,tem)))))
  567.        ((and (consp type)
  568.          (eq (car type) 'satisfies)
  569.          (consp (cdr type))
  570.          (cadr type)
  571.          (symbolp (cadr type))
  572.          (symbol-package (cadr type))
  573.          (null (cddr type))
  574.          `(,(cadr type) ,x)))
  575.        ((subtypep type 'fixnum)
  576.         (setq tem (si::normalize-type type))
  577.         (and (consp tem)
  578.          (si::fixnump (second tem))
  579.          (si::fixnump (third  tem))
  580.          `(let ((.tem ,x))
  581.             (declare (type ,(result-type x) .tem))
  582.             (and (typep .tem 'fixnum)
  583.              (>=  (the fixnum .tem) ,(second tem))
  584.              (<=  (the fixnum .tem) ,(third tem))))))
  585.        ((and (symbolp type)
  586.          (setq tem (get type 'si::s-data)))
  587.         (cond ((or (si::s-data-frozen tem)
  588.                *frozen-defstructs*)
  589.            (struct-type-opt x tem))
  590.           (t
  591.            `(si::structure-subtype-p
  592.              ,x ',type))))
  593. ;       ((and (print (list 'slow 'typep type)) nil))
  594.        (t nil)))
  595.     (and new (c1expr `(the boolean , new)))))
  596.  
  597. ;; this is going the wrong way.  want to go up..
  598. (defun struct-type-opt (x sd)
  599.   (let ((s (gensym))
  600.     (included (get-included (si::s-data-name sd))))
  601.     `(let ((,s ,x))
  602.        (and
  603.      (si::structurep ,s)
  604.      ,(cond ((< (length included) 3)
  605.          `(or ,@
  606.               (mapcar #'(lambda (x)
  607.                   `(eq (si::structure-def ,s)
  608.                        ,(name-sd1 x)))
  609.                   included)))
  610.         (t `(si::structure-subtype-p ,s
  611.                         ,(name-sd1
  612.                            (si::s-data-name sd)))))))))
  613.  
  614. (defun get-included (name)
  615.   (let ((sd (get name 'si::s-data)))
  616.     (cons (si::s-data-name sd)
  617.       (mapcan 'get-included
  618.           (si::s-data-included sd)))))
  619.   
  620.  
  621.  
  622. (si::putprop 'typep 'co1typep 'co1)            
  623.  
  624. (defun co1schar (f args) f
  625.    (and (listp (car args)) (not *safe-compile*)
  626.     (cdr args)
  627.     (eq (caar args) 'symbol-name)
  628.     (c1expr `(aref (the string ,(second (car args)))
  629.             ,(second args)))))
  630.  
  631. (si::putprop 'schar 'co1schar 'co1)
  632.  
  633. (si::putprop 'cons 'co1cons 'co1)
  634. ;; turn repetitious cons's into a list*
  635.  
  636. (defun cons-to-lista (x)
  637.   (let ((tem  (last x)))
  638.     (cond 
  639.     ((and (consp tem)
  640.          (consp (car tem))
  641.          (eq (caar tem) 'cons)
  642.          (eql (length (cdar tem)) 2)
  643.          (cons-to-lista (append (butlast x)
  644.                     (cdar tem)))))
  645.     (t x))))
  646.          
  647.  
  648. (defun co1cons (f args) f
  649.   (let ((tem (and (eql (length args) 2) (cons-to-lista args))))
  650.     (and (not (eq tem args))
  651.      (c1expr  (if (equal '(nil) (last tem))
  652.              (cons 'list (butlast tem))
  653.              (cons 'list* tem))))))
  654.  
  655. ;; I don't feel it is good to replace the list call, but rather
  656. ;; usually better the other way around.  We removed c1list
  657. ;; because of possible feedback.
  658.  
  659. (defun c1nth-condition (args)
  660.        (and (not (endp args))
  661.             (not (endp (cdr args)))
  662.             (endp (cddr args))
  663.             (numberp (car args))
  664.             (<= 0 (car args) 7)))
  665.  
  666. (defun c1nth (args)
  667.        (c1expr (case (car args)
  668.                      (0 (cons 'car (cdr args)))
  669.                      (1 (cons 'cadr (cdr args)))
  670.                      (2 (cons 'caddr (cdr args)))
  671.                      (3 (cons 'cadddr (cdr args)))
  672.                      (4 (list 'car (cons 'cddddr (cdr args))))
  673.                      (5 (list 'cadr (cons 'cddddr (cdr args))))
  674.                      (6 (list 'caddr (cons 'cddddr (cdr args))))
  675.                      (7 (list 'cadddr (cons 'cddddr (cdr args))))
  676.                      )))
  677.  
  678. (defun c1nthcdr-condition (args)
  679.        (and (not (endp args))
  680.             (not (endp (cdr args)))
  681.             (endp (cddr args))
  682.             (numberp (car args))
  683.             (<= 0 (car args) 7)))
  684.  
  685. (defun c1nthcdr (args)
  686.        (c1expr (case (car args)
  687.                      (0 (cadr args))
  688.                      (1 (cons 'cdr (cdr args)))
  689.                      (2 (cons 'cddr (cdr args)))
  690.                      (3 (cons 'cdddr (cdr args)))
  691.                      (4 (cons 'cddddr (cdr args)))
  692.                      (5 (list 'cdr (cons 'cddddr (cdr args))))
  693.                      (6 (list 'cddr (cons 'cddddr (cdr args))))
  694.                      (7 (list 'cdddr (cons 'cddddr (cdr args))))
  695.                      )))
  696.  
  697. (defun c1rplaca-nthcdr (args &aux (info (make-info)))
  698.   (when (or (endp args) (endp (cdr args)) (endp (cddr args)))
  699.         (too-few-args 'si:rplaca-nthcdr 3 (length args)))
  700.   (unless (endp (cdddr args))
  701.           (too-few-args 'si:rplaca-nthcdr 3 (length args)))
  702.   (if (and (numberp (cadr args)) (<= 0 (cadr args) 10))
  703.       (let  ((x (gensym))(y (gensym)))
  704.     (c1expr
  705.      `(let ((,x ,(car args))
  706.         (,y ,(third args)))
  707.         (setf ,x (nthcdr ,(cadr args) ,x))
  708.         (setf (car ,x) ,y)
  709.         ,y)))
  710.       (list 'call-global info 'si:rplaca-nthcdr (c1args args info))))
  711.  
  712.  
  713. ;; Facilities for faster reading and writing from file streams.
  714. ;; You must declare the stream to be :in-file
  715. ;; or :out-file
  716.  
  717. (si::putprop 'read-byte 'co1read-byte 'co1)
  718. (si::putprop 'read-char 'co1read-char 'co1)
  719. (si::putprop 'write-byte 'co1write-byte 'co1)
  720. (si::putprop 'write-char 'co1write-char 'co1)
  721.  
  722.  
  723.  
  724. (defun fast-read (args read-fun)
  725.   (cond
  726.     ((and (not *safe-compile*)
  727.       (< *space* 2)
  728.       (null (second args))
  729.       (boundp 'si::*eof*))
  730.      (cond
  731.        ((atom (car args))
  732.     (or (car args) (setq args (cons '*standard-input* (cdr args))))
  733.     (let ((stream (car args))
  734.           (eof (third args)))
  735.       `(let ((stt (fp-ok ,stream))
  736.          (ans 0))
  737.          (declare (fixnum stt ans))
  738.          (cond ((eql stt 0)
  739.             (,read-fun ,stream  ,eof)
  740.              )
  741.            (t (setq ans  (qgetc1 stt))
  742.               (cond ((and (eql ans ,si::*eof*)
  743.                   (qfeof  (the fixnum
  744.                            (fp-ok (the stream ,stream))))
  745.                   ) ,eof)
  746.                 (t ,(if (eq read-fun 'read-char1)
  747.                        '(code-char ans) 'ans))
  748.                        ))))))
  749.        (t
  750.     `(let ((.strm. ,(car args)))
  751.        (declare (type ,(result-type (car args)) .strm.))
  752.          ,(fast-read (cons '.strm. (cdr args)) read-fun)))))))
  753.  
  754. (defun co1read-byte (f args &aux tem) f
  755.   (cond ((setq tem (fast-read args 'read-byte1))
  756.      (let ((*space* 10))        ;prevent recursion!
  757.        (c1expr tem)))))
  758.  
  759. (defun co1read-char (f args &aux tem) f
  760.   (cond ((setq tem (fast-read args 'read-char1))
  761.      (let ((*space* 10))        ;prevent recursion!
  762.        (c1expr tem)))))    
  763.  
  764. (defun cfast-write (args write-fun)
  765.   (cond
  766.     ((and (not *safe-compile*)
  767.       (< *space* 2)
  768.       (boundp 'si::*eof*))
  769.      (let ((stream (second args)))
  770.        (or stream (setq stream '*standard-output*))
  771.      (cond
  772.        ((atom stream)
  773.     `(let ((stt (fp-ok ,stream)))
  774.          (declare (fixnum stt))
  775.          (cond ((eql stt 0)
  776.             (,write-fun  .ch ,stream))
  777.            (t (the fixnum (qputc .ch stt))))))
  778.        (t `(let ((.str ,stream))
  779.          (declare (type ,(result-type stream) .str))
  780.          ,(cfast-write (list '.ch '.str) write-fun))))))))
  781.  
  782. (defun co1write-byte (f args) f
  783.   (let ((tem (cfast-write args 'write-byte)))
  784.     (if tem (let ((*space* 10))
  785.           (c1expr
  786.         `(let ((.ch ,(car args)))
  787.            (declare (fixnum .ch))
  788.            ,tem
  789.            ,(if (atom (car args)) (car args) '.ch)))))))
  790.  
  791. (defun co1write-char (f args) f
  792.   (let ((tem (cfast-write args 'write-char)))
  793.     (if tem (let ((*space* 10))
  794.           (c1expr
  795.         `(let ((.ch ,(car args)))
  796.            (declare (character .ch))
  797.            ,tem
  798.            ,(if (atom (car args)) (car args) '.ch)))))))
  799.  
  800.  
  801.  
  802. (defvar *aet-types*
  803.   #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT
  804.             SIGNED-CHAR
  805.             UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT))
  806.  
  807.  
  808. (defun aet-c-type (type)
  809.   (ecase type
  810.     ((t) "object")
  811.     ((string-char signed-char) "char")
  812.     (fixnum "fixnum")
  813.     (unsigned-char "unsigned char")
  814.     (unsigned-short "unsigned short")
  815.     (signed-short "short")
  816.     (unsigned-short "unsigned short")
  817.     (long-float "longfloat")
  818.     (short-float "shortfloat")))
  819.  
  820.  
  821. (si:putprop 'vector-push 'co1vector-push 'co1)
  822. (si:putprop 'vector-push-extend 'co1vector-push 'co1)
  823. (defun co1vector-push (f args) f
  824.   (unless
  825.    (or *safe-compile*
  826.        (> *space* 3)
  827.        (null (cdr args))
  828.        )
  829.    (let ((*space* 10))
  830.      (c1expr
  831.       `(let* ((.val ,(car args))
  832.           (.v ,(second args))
  833.           (.i (fill-pointer .v))
  834.           (.dim (array-total-size .v)))
  835.      (declare (fixnum .i .dim))
  836.      (declare (type ,(result-type (second args)) .v))
  837.      (declare (type ,(result-type (car args)) .val))
  838.      (cond ((< .i .dim)
  839.         (the fixnum (si::fill-pointer-set .v (the fixnum (+ 1 .i))))
  840.         (si::aset .v .i .val)
  841.         .i)
  842.            (t ,(cond ((eq f 'vector-push-extend)
  843.               `(vector-push-extend .val
  844.                            .v ,@(cddr args)))))))))))
  845.  
  846. (defun constant-fold-p (x)
  847.   (cond ((constantp x) t)
  848.     ((atom  x) nil)
  849.     ((eq (car x) 'the)
  850.      (constant-fold-p (third x)))
  851.     ((and 
  852.           (symbolp (car x))
  853.           (eq (get (car x) 'co1)
  854.           'co1constant-fold))
  855.      (dolist (w (cdr x))
  856.          (or (constant-fold-p w)
  857.              (return-from constant-fold-p nil)))
  858.      t)
  859.     (t nil)))
  860.  
  861. (defun co1constant-fold (f args )
  862.   (cond ((and (fboundp f)
  863.           (dolist (v args t)
  864.               (or (constant-fold-p v)
  865.               (return-from co1constant-fold nil))))
  866.      (c1expr (cmp-eval (cons f args))))))
  867.  
  868.  
  869. (si::putprop 'do 'co1special-fix-decl 'co1special)
  870. (si::putprop 'do* 'co1special-fix-decl 'co1special)
  871. (si::putprop 'prog 'co1special-fix-decl 'co1special)
  872. (si::putprop 'prog* 'co1special-fix-decl 'co1special)
  873.  
  874. (defun co1special-fix-decl (f args)
  875.   (flet ((fixup (forms &aux decls )
  876.       (block nil
  877.          (tagbody
  878.           top
  879.           (or (consp forms) (go end))
  880.           (let ((tem (car forms)))
  881.             (if (and (consp tem)
  882.                  (setq tem  (cmp-macroexpand tem))
  883.                  (eq (car tem) 'declare))
  884.             (progn (push tem decls) (pop forms))
  885.               (go end)))
  886.               (go top)
  887.                   ; all decls made explicit.
  888.               end
  889.              (return  (nconc (nreverse decls) forms))))))
  890.     (c1expr
  891.       (cmp-macroexpand
  892.         (case f
  893.           ((do do*) `(,f ,(car args)
  894.                  ,(second args)
  895.                  ,@ (fixup (cddr args))))
  896.           ((prog prog*)
  897.            `(,f ,(car args)
  898.             ,@ (fixup (cdr args)))))))))
  899. (si::putprop 'sublis 'co1sublis 'co1)
  900. (defun co1sublis (f args &aux test) f
  901.  (and (case (length args)
  902.     (2 (setq test 'eql))
  903.     (4 (and (eq (third args) :test)
  904.         (cond ((member (fourth args) '(equal (function equal))) (setq test 'equal))
  905.               ((member (fourth args) '(eql (function eql))) (setq test 'eql))
  906.                    ((member (fourth args) '(eq (function eq))) (setq test 'eq))
  907.               ))))
  908.       (let ((s (gensym)))
  909.     (c1expr `(let ((,s ,(car args)))
  910.            (sublis1 ,s ,(second args) ',test))))))
  911.  
  912.  
  913. (defun sublis1-inline (a b c)
  914.   (let ((tst (car (find (cadr c) *objects* :key 'cadr))))
  915.     (or (member tst '(eq equal eql)) (error "bad test"))
  916.   (wt "(check_alist("
  917.       a
  918.      "),sublis1("a "," b "," (format nil "~(&~a~)))" tst))))
  919.  
  920.   
  921. ;; end new          
  922.       
  923. (defun c1list-nth (args &aux (info (make-info)))
  924.   (when (or (endp args) (endp (cdr args)))
  925.         (too-few-args 'si:rplaca-nthcdr 2 (length args)))
  926.   (unless (endp (cddr args))
  927.           (too-few-args 'si:rplaca-nthcdr 2 (length args)))
  928.   (if (and (numberp (car args)) (<= 0 (car args) 10))
  929.       (list 'list-nth-immediate info
  930.             (car args)
  931.             (c1args (list (cadr args)) info))
  932.       (list 'call-global info 'si:list-nth (c1args args info))))
  933.  
  934. (defun c2list-nth-immediate (index args &aux (l (next-cvar))
  935.                                              (*vs* *vs*) (*inline-blocks* 0))
  936.   (setq args (inline-args args '(t t)))
  937.   (wt-nl "{object V" l "= ")
  938.   (if *safe-compile*
  939.       (progn
  940.        (dotimes** (i index) (wt "cdr("))
  941.        (wt (car args))
  942.        (dotimes** (i index) (wt ")"))
  943.        (wt ";")
  944.        (wt-nl "if((type_of(V" l ")!=t_cons) && (" (car args) "!= Cnil))")
  945.        (wt-nl " FEwrong_type_argument(Scons,V" l ");")
  946.        )
  947.       (progn
  948.        (wt-nl (car args))
  949.        (dotimes** (i index) (wt-nl "->c.c_cdr"))
  950.        (wt ";")))
  951.   (unwind-exit (list 'CAR l))
  952.   (wt "}")
  953.   (close-inline-blocks)
  954.   )
  955.  
  956.  
  957.