ompayne
/
sicp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add drop call into apply-generic 

This is a little bit messy in that apply-generic changes behaviour
depending on the operation.
This commit is contained in:
Oliver Payne 2022-02-25 22:47:34 +00:00
parent ed1702ee13
commit d391dded38
1 changed files with 25 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
2_78.rkt
View File

@ -105,16 +105,22 @@
coerced-args
(coerce-args args (cdr type-tags))))))
(let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((coerced-args (coerce-args args type-tags)))
(if (not (null? coerced-args))
(apply apply-generic (cons op coerced-args))
(error "Can't coerce arguments to a common type"
(list op type-tags))))
(error "Too few args")))))
(proc (get op type-tags))
(result
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((coerced-args (coerce-args args type-tags)))
(if (not (null? coerced-args))
(apply apply-generic (cons op coerced-args))
(error "Can't coerce arguments to a common type"
(list op type-tags))))
(error "Too few args")))))
(if (and (pair? result)
(not (or (eq? op 'raise)
(eq? op 'lower))))
(drop result)
result)))
;; Scheme numbers
@ -233,7 +239,7 @@
(make-integer
(/ (numer x) (denom x)))))
(put 'make 'rational
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
'done)
@ -391,13 +397,12 @@
(define (project x) (apply-generic 'project x))
(define (drop x)
(if (null? x)
'()
(let ((p (project x)))
(cond ((null? p) x)
((equ? x (raise p))
(drop p))
(else x)))))
(and (type-tagged? x)
(let ((p (project x)))
(cond ((null? p) x)
((equ? x (raise p))
(drop p))
(else x)))))
(install-scheme-number-package)
(install-integer-package)
@ -420,6 +425,8 @@
(cond ((pair? datum) (cdr datum))
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define type-tagged? pair?)
;; Coercion