home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / sos / macros.scm < prev    next >
Text File  |  2000-04-05  |  18KB  |  541 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: macros.scm,v 1.10 2000/04/06 03:43:15 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1993-2000 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Macros
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define (transform:define-class name superclasses . slot-arguments)
  26.   (let ((lose
  27.      (lambda (s a)
  28.        (serror 'DEFINE-CLASS (string-append "Malformed " s ":") a))))
  29.     (call-with-values (lambda () (parse-define-class-name name lose))
  30.       (lambda (name post-definitions separator)
  31.     (if (not (list? superclasses))
  32.         (lose "superclasses" superclasses))
  33.     (let ((pre-definitions
  34.            (extract-generic-definitions! slot-arguments name separator
  35.                          lose)))
  36.       `(BEGIN
  37.          ,@pre-definitions
  38.          (DEFINE ,name
  39.            (,(make-absolute-reference 'MAKE-CLASS)
  40.         ',name
  41.         (,(make-absolute-reference 'LIST) ,@superclasses)
  42.         (,(make-absolute-reference 'LIST)
  43.          ,@(map
  44.             (lambda (arg)
  45.               (cond ((symbol? arg)
  46.                  `',arg)
  47.                 ((and (pair? arg)
  48.                   (symbol? (car arg))
  49.                   (list? (cdr arg)))
  50.                  `(,(make-absolute-reference 'LIST)
  51.                    ',(car arg)
  52.                    ,@(let loop ((plist (cdr arg)))
  53.                    (cond ((null? plist)
  54.                       '())
  55.                      ((and (symbol? (car plist))
  56.                            (pair? (cdr plist)))
  57.                       (cons* `',(car plist)
  58.                          (cadr plist)
  59.                          (loop (cddr plist))))
  60.                      (else
  61.                       (lose "slot argument" arg))))))
  62.                 (else
  63.                  (lose "slot argument" arg))))
  64.             slot-arguments))))
  65.          ,@post-definitions))))))
  66.  
  67. (define (parse-define-class-name name lose)
  68.   (call-with-values (lambda () (parse-define-class-name-1 name lose))
  69.     (lambda (class-name alist)
  70.       (let ((post-definitions '())
  71.         (separator #f))
  72.     (let ((alist
  73.            (if (assq 'PREDICATE alist)
  74.            alist
  75.            (cons '(PREDICATE) alist)))
  76.           (post-def
  77.            (lambda (def)
  78.          (set! post-definitions (cons def post-definitions))
  79.          unspecific)))
  80.       (for-each
  81.        (lambda (option)
  82.          (case (car option)
  83.            ((PREDICATE)
  84.         (let ((pn
  85.                (cond ((null? (cdr option))
  86.                   (default-predicate-name class-name))
  87.                  ((and (pair? (cdr option))
  88.                    (or (symbol? (cadr option))
  89.                        (false? (cadr option)))
  90.                    (null? (cddr option)))
  91.                   (cadr option))
  92.                  (else (lose "class option" option)))))
  93.           (if pn
  94.               (post-def
  95.                `(DEFINE ,pn
  96.               (,(make-absolute-reference 'INSTANCE-PREDICATE)
  97.                ,class-name))))))
  98.            ((CONSTRUCTOR)
  99.         (call-with-values
  100.             (lambda ()
  101.               (parse-constructor-option class-name lose option))
  102.           (lambda (name slots ii-args)
  103.             (post-def
  104.              `(DEFINE ,name
  105.             (,(make-absolute-reference 'INSTANCE-CONSTRUCTOR)
  106.              ,class-name
  107.              ',slots
  108.              ,@(map (lambda (x) `',x) ii-args)))))))
  109.            ((SEPARATOR)
  110.         (if (or separator
  111.             (null? (cdr option))
  112.             (not (string? (cadr option)))
  113.             (not (null? (cddr option))))
  114.             (lose "class option" option))
  115.         (set! separator (cadr option))
  116.         unspecific)
  117.            (else (lose "class option" option))))
  118.        alist))
  119.     (values class-name post-definitions (or separator "-"))))))
  120.  
  121. (define (parse-define-class-name-1 name lose)
  122.   (cond ((symbol? name)
  123.      (values name '()))
  124.     ((and (pair? name)
  125.           (symbol? (car name))
  126.           (list? (cdr name)))
  127.      (values (car name)
  128.          (map (lambda (option)
  129.             (if (pair? option)
  130.                 option
  131.                 (list option)))
  132.               (cdr name))))
  133.     (else (lose "class name" name))))
  134.  
  135. (define (parse-constructor-option class-name lose option)
  136.   (cond ((match `(,symbol? ,list-of-symbols? . ,optional?) (cdr option))
  137.      (values (cadr option) (caddr option) (cdddr option)))
  138.     ((match `(,list-of-symbols? . ,optional?) (cdr option))
  139.      (values (default-constructor-name class-name)
  140.          (cadr option)
  141.          (cddr option)))
  142.     (else
  143.      (lose "class option" option))))
  144.  
  145. (define (list-of-symbols? x)
  146.   (and (list? x) (for-all? x symbol?)))
  147.  
  148. (define (optional? x)
  149.   (or (null? x) (and (pair? x) (null? (cdr x)))))
  150.  
  151. (define (default-predicate-name class-name)
  152.   (intern (string-append (strip-angle-brackets class-name) "?")))
  153.  
  154. (define (default-constructor-name class-name)
  155.   (intern (string-append "make-" (strip-angle-brackets class-name))))
  156.  
  157. (define (extract-generic-definitions! slot-arguments name separator lose)
  158.   (let ((definitions '()))
  159.     (for-each
  160.      (lambda (arg)
  161.        (if (and (pair? arg)
  162.         (symbol? (car arg))
  163.         (list? (cdr arg)))
  164.        (let loop ((plist (cdr arg)) (prev arg))
  165.          (if (and (pair? plist) (pair? (cdr plist)))
  166.          (if (eq? 'DEFINE (car plist))
  167.              (begin
  168.                (let ((keyword?
  169.                   (lambda (element)
  170.                 (or (eq? 'ACCESSOR element)
  171.                     (eq? 'MODIFIER element)
  172.                     (eq? 'INITPRED element)))))
  173.              (if (not (or (eq? 'STANDARD (cadr plist))
  174.                       (keyword? (cadr plist))
  175.                       (and (list? (cadr plist))
  176.                        (for-all? (cadr plist) keyword?))))
  177.                  (lose "DEFINE property" arg)))
  178.                (set-cdr! prev (cddr plist))
  179.                (set! definitions
  180.                  (append! (translate-define-arg (cadr plist)
  181.                                 name
  182.                                 separator
  183.                                 arg)
  184.                       definitions)))
  185.              (loop (cddr plist) (cdr plist)))))))
  186.      slot-arguments)
  187.     definitions))
  188.  
  189. (define (translate-define-arg arg name separator slot-argument)
  190.   (let ((translate
  191.      (lambda (keyword standard? arity generate)
  192.        (if (or (and standard? (eq? 'STANDARD arg))
  193.            (eq? keyword arg)
  194.            (and (pair? arg) (memq keyword arg)))
  195.            `((DEFINE
  196.            ,(or (plist-lookup keyword (cdr slot-argument) #f)
  197.             (let ((name
  198.                    (intern
  199.                 (generate
  200.                  (string-append (strip-angle-brackets name)
  201.                         separator
  202.                         (symbol->string
  203.                          (car slot-argument)))))))
  204.               (set-cdr! slot-argument
  205.                     (cons* keyword name (cdr slot-argument)))
  206.               name))
  207.            (,(make-absolute-reference 'MAKE-GENERIC-PROCEDURE)
  208.             ,arity)))
  209.            '()))))
  210.     (append (translate 'ACCESSOR #t 1
  211.                (lambda (root) root))
  212.         (translate 'MODIFIER #t 2
  213.                (lambda (root) (string-append "set-" root "!")))
  214.         (translate 'INITPRED #f 1
  215.                (lambda (root) (string-append root "-initialized?"))))))
  216.  
  217. (define (plist-lookup key plist default)
  218.   (let loop ((plist plist))
  219.     (if (and (pair? plist) (pair? (cdr plist)))
  220.     (if (eq? key (car plist))
  221.         (cadr plist)
  222.         (loop (cddr plist)))
  223.     default)))
  224.  
  225. (define (strip-angle-brackets symbol)
  226.   (let ((s (symbol->string symbol)))
  227.     (if (and (fix:>= (string-length s) 2)
  228.          (char=? #\< (string-ref s 0))
  229.          (char=? #\> (string-ref s (fix:- (string-length s) 1))))
  230.     (substring s 1 (fix:- (string-length s) 1))
  231.     s)))
  232.  
  233. (define (transform:define-generic name lambda-list)
  234.   (let ((mname 'DEFINE-GENERIC))
  235.     (if (not (symbol? name))
  236.     (serror mname "Malformed generic procedure name:" name))
  237.     (call-with-values (lambda () (parse-lambda-list lambda-list #f mname))
  238.       (lambda (required optional rest)
  239.     `(DEFINE ,name
  240.        (,(make-absolute-reference 'MAKE-GENERIC-PROCEDURE)
  241.         ',(let ((low (length required)))
  242.         (cond (rest (cons low #f))
  243.               ((null? optional) low)
  244.               (else (cons low (+ low (length optional))))))
  245.         ',name))))))
  246.  
  247. (define (transform:define-method name lambda-list . body)
  248.   (%transform:define-method name lambda-list body 'DEFINE-METHOD
  249.                 generate-method-definition))
  250.  
  251. (define (transform:define-computed-method name lambda-list . body)
  252.   (%transform:define-method name lambda-list body 'DEFINE-COMPUTED-METHOD
  253.                 generate-computed-method-definition))
  254.  
  255. (define (%transform:define-method name lambda-list body mname generator)
  256.   (if (not (symbol? name))
  257.       (serror mname "Malformed generic procedure name:" name))
  258.   (call-with-values (lambda () (parse-lambda-list lambda-list #t mname))
  259.     (lambda (required optional rest)
  260.       (call-with-values (lambda () (extract-required-specializers required))
  261.     (lambda (required specializers)
  262.       (generator name required specializers optional rest body))))))
  263.  
  264. (define (generate-method-definition name required specializers optional rest
  265.                     body)
  266.   `(,(make-absolute-reference 'ADD-METHOD)
  267.     ,name
  268.     ,(make-method-sexp name required optional rest specializers body)))
  269.  
  270. (define (generate-computed-method-definition name required specializers
  271.                          optional rest body)
  272.   `(,(make-absolute-reference 'ADD-METHOD)
  273.     ,name
  274.     (,(make-absolute-reference 'MAKE-COMPUTED-METHOD)
  275.      (,(make-absolute-reference 'LIST) ,@specializers)
  276.      ,(make-named-lambda name required optional rest body))))
  277.  
  278. (define (transform:define-computed-emp name key lambda-list . body)
  279.   (let ((mname 'DEFINE-COMPUTED-EMP))
  280.     (if (not (symbol? name))
  281.     (serror mname "Malformed generic procedure name:" name))
  282.     (call-with-values (lambda () (parse-lambda-list lambda-list #t mname))
  283.       (lambda (required optional rest)
  284.     (call-with-values (lambda () (extract-required-specializers required))
  285.       (lambda (required specializers)
  286.         `(,(make-absolute-reference 'ADD-METHOD)
  287.           ,name
  288.           (,(make-absolute-reference 'MAKE-COMPUTED-EMP)
  289.            ,key
  290.            (,(make-absolute-reference 'LIST) ,@specializers)
  291.            ,(make-named-lambda name required optional rest body)))))))))
  292.  
  293. (define (transform:method lambda-list . body)
  294.   (call-with-values (lambda () (parse-lambda-list lambda-list #t 'METHOD))
  295.     (lambda (required optional rest)
  296.       (call-with-values (lambda () (extract-required-specializers required))
  297.     (lambda (required specializers)
  298.       (make-method-sexp #f required optional rest specializers body))))))
  299.  
  300. (define (extract-required-specializers required)
  301.   (let loop ((required required) (names '()) (specializers '()))
  302.     (cond ((null? required)
  303.        (values (reverse! names)
  304.            (reverse! (let loop ((specializers specializers))
  305.                    (if (and (not (null? specializers))
  306.                     (eq? '<OBJECT> (car specializers))
  307.                     (not (null? (cdr specializers))))
  308.                    (loop (cdr specializers))
  309.                    specializers)))))
  310.       ((pair? (car required))
  311.        (loop (cdr required)
  312.          (cons (caar required) names)
  313.          (cons (cadar required) specializers)))
  314.       (else
  315.        (loop (cdr required)
  316.          (cons (car required) names)
  317.          (cons '<OBJECT> specializers))))))
  318.  
  319. (define (make-method-sexp name required optional rest specializers body)
  320.   (let ((normal
  321.      (lambda ()
  322.        (call-with-values (lambda () (call-next-method-used? body))
  323.          (lambda (body used?)
  324.            (let ((s `(,(make-absolute-reference 'LIST) ,@specializers))
  325.              (l (make-named-lambda name required optional rest body)))
  326.          (if used?
  327.              `(,(make-absolute-reference 'MAKE-CHAINED-METHOD)
  328.                ,s
  329.                (LAMBDA (CALL-NEXT-METHOD) ,l))
  330.              `(,(make-absolute-reference 'MAKE-METHOD) ,s ,l))))))))
  331.     (if (and (null? optional)
  332.          (not rest)
  333.          (not (eq? '<OBJECT> (car specializers))))
  334.     (case (length required)
  335.       ((1)
  336.        (cond ((match `((SLOT-VALUE ,(car required) ',symbol?)) body)
  337.           `(,(make-absolute-reference 'SLOT-ACCESSOR-METHOD)
  338.             ,(car specializers)
  339.             ,(caddar body)))
  340.          ((match `((SLOT-INITIALIZED? ,(car required) ',symbol?)) body)
  341.           `(,(make-absolute-reference 'SLOT-INITPRED-METHOD)
  342.             ,(car specializers)
  343.             ,(caddar body)))
  344.          (else (normal))))
  345.       ((2)
  346.        (if (and (null? (cdr specializers))
  347.             (match `((SET-SLOT-VALUE! ,(car required)
  348.                           ',symbol?
  349.                           ,(cadr required)))
  350.                body))
  351.            `(,(make-absolute-reference 'SLOT-MODIFIER-METHOD)
  352.          ,(car specializers)
  353.          ,(caddar body))
  354.            (normal)))
  355.       (else (normal)))
  356.     (normal))))
  357.  
  358. (define (match pattern instance)
  359.   (cond ((procedure? pattern)
  360.      (pattern instance))
  361.     ((pair? pattern)
  362.      (and (pair? instance)
  363.           (match (car pattern) (car instance))
  364.           (match (cdr pattern) (cdr instance))))
  365.     (else
  366.      (eqv? pattern instance))))
  367.  
  368. (define (call-next-method-used? body)
  369.   (if (null? body)
  370.       (values body #f)
  371.       (let ((body
  372.          (let loop ((body body))
  373.            (cond ((or (not (symbol? (car body)))
  374.               (null? (cdr body)))
  375.               body)
  376.              ((eq? (car body) 'CALL-NEXT-METHOD)
  377.               (loop (cdr body)))
  378.              (else
  379.               (cons (car body) (loop (cdr body))))))))
  380.     (values body
  381.         (free-variable? 'CALL-NEXT-METHOD
  382.                 (syntax* body))))))
  383.  
  384. (define free-variable?
  385.   (letrec
  386.       ((do-expr
  387.     (lambda (name expr)
  388.       ((scode-walk scode-walker expr) name expr)))
  389.        (do-exprs
  390.     (lambda (name exprs)
  391.       (if (null? exprs)
  392.           '()
  393.           (or (do-expr name (car exprs))
  394.           (do-exprs name (cdr exprs))))))
  395.        (scode-walker
  396.     (make-scode-walker
  397.      (lambda (name expr) name expr #f)
  398.      `((ACCESS
  399.         ,(lambda (name expr)
  400.            name
  401.            (if (access-environment expr)
  402.            (illegal expr)
  403.            #f)))
  404.        (ASSIGNMENT
  405.         ,(lambda (name expr)
  406.            (or (eq? name (assignment-name expr))
  407.            (do-expr name (assignment-value expr)))))
  408.        (COMBINATION
  409.         ,(lambda (name expr)
  410.            (or (do-expr name (combination-operator expr))
  411.            (do-exprs name (combination-operands expr)))))
  412.        (COMMENT
  413.         ,(lambda (name expr)
  414.            (do-expr name (comment-expression expr))))
  415.        (CONDITIONAL
  416.         ,(lambda (name expr)
  417.            (do-exprs name (conditional-components expr list))))
  418.        (DELAY
  419.         ,(lambda (name expr)
  420.            (do-expr name (delay-expression expr))))
  421.        (DISJUNCTION
  422.         ,(lambda (name expr)
  423.            (do-exprs name (disjunction-components expr list))))
  424.        (DEFINITION
  425.         ,(lambda (name expr)
  426.            (and (not (eq? name (definition-name expr)))
  427.             (do-expr name (definition-value expr)))))
  428.        (IN-PACKAGE ,(lambda (name expr) name (illegal expr)))
  429.        (LAMBDA
  430.         ,(lambda (name expr)
  431.            (lambda-components expr
  432.          (lambda (lname required optional rest auxiliary decls body)
  433.            lname decls
  434.            (and (not (or (memq name required)
  435.                  (memq name optional)
  436.                  (eq? name rest)
  437.                  (memq name auxiliary)))
  438.             (do-expr name body))))))
  439.        (SEQUENCE
  440.         ,(lambda (name expr)
  441.            (do-exprs name (sequence-actions expr))))
  442.        (VARIABLE
  443.         ,(lambda (name expr)
  444.            (eq? name (variable-name expr)))))))
  445.        (illegal (lambda (expr) (error "Illegal expression:" expr))))
  446.     do-expr))
  447.  
  448. (define (parse-lambda-list lambda-list allow-specializers? specform)
  449.   specform
  450.   (let ((required '())
  451.     (optional '())
  452.     (rest #f))
  453.     (letrec
  454.     ((parse-required
  455.       (lambda (lambda-list)
  456.         (cond ((null? lambda-list)
  457.            (finish))
  458.           ((pair? lambda-list)
  459.            (cond ((or (valid-name? (car lambda-list))
  460.                   (and allow-specializers?
  461.                    (pair? (car lambda-list))
  462.                    (valid-name? (caar lambda-list))
  463.                    (pair? (cdar lambda-list))
  464.                    (null? (cddar lambda-list))))
  465.               (set! required (cons (car lambda-list) required))
  466.               (parse-required (cdr lambda-list)))
  467.              ((eq? #!optional (car lambda-list))
  468.               (parse-optional (cdr lambda-list)))
  469.              ((eq? #!rest (car lambda-list))
  470.               (parse-rest (cdr lambda-list)))
  471.              (else
  472.               (illegal-element lambda-list))))
  473.           ((symbol? lambda-list)
  474.            (set! rest lambda-list)
  475.            (finish))
  476.           (else
  477.            (illegal-tail lambda-list)))))
  478.      (parse-optional
  479.       (lambda (lambda-list)
  480.         (cond ((null? lambda-list)
  481.            (finish))
  482.           ((pair? lambda-list)
  483.            (cond ((valid-name? (car lambda-list))
  484.               (set! optional (cons (car lambda-list) optional))
  485.               (parse-optional (cdr lambda-list)))
  486.              ((eq? #!optional (car lambda-list))
  487.               (error "#!optional may not recur:" lambda-list))
  488.              ((eq? #!rest (car lambda-list))
  489.               (parse-rest (cdr lambda-list)))
  490.              (else
  491.               (illegal-element lambda-list))))
  492.           ((symbol? lambda-list)
  493.            (set! rest lambda-list)
  494.            (finish))
  495.           (else
  496.            (illegal-tail lambda-list)))))
  497.      (parse-rest
  498.       (lambda (lambda-list)
  499.         (if (and (pair? lambda-list)
  500.              (null? (cdr lambda-list)))
  501.         (if (valid-name? (car lambda-list))
  502.             (begin
  503.               (set! rest (car lambda-list))
  504.               (finish))
  505.             (illegal-element lambda-list))
  506.         (illegal-tail lambda-list))))
  507.      (valid-name?
  508.       (lambda (element)
  509.         (and (symbol? element)
  510.          (not (eq? #!optional element))
  511.          (not (eq? #!rest element)))))
  512.      (finish
  513.       (lambda ()
  514.         (values (reverse! required)
  515.             (reverse! optional)
  516.             rest)))
  517.      (illegal-tail
  518.       (lambda (lambda-list)
  519.         (error "Illegal parameter list tail:" lambda-list)))
  520.      (illegal-element
  521.       (lambda (lambda-list)
  522.         (error "Illegal parameter list element:" (car lambda-list)))))
  523.       (parse-required lambda-list))))
  524.  
  525. (define (make-named-lambda name required optional rest body)
  526.   (let ((bvl
  527.      (append required
  528.          (if (null? optional)
  529.              '()
  530.              `(#!OPTIONAL ,@optional))
  531.          (or rest '()))))
  532.     (if name
  533.     `(NAMED-LAMBDA (,name ,@bvl) ,@body)
  534.     `(LAMBDA ,bvl ,@body))))
  535.  
  536. (define (make-absolute-reference name)
  537.   `(ACCESS ,name #F))
  538.  
  539. (define (serror procedure message . objects)
  540.   procedure
  541.   (apply error message objects))