File: xprim.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (125 lines) | stat: -rw-r--r-- 3,436 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; Hairier exceptions & interrupts.
; Enable generic arithmetic, informative error messages, etc.

; Deal with optional arguments, etc. to primitives.
; This is not necessarily the cleanest way to do this, and certainly not
; the most efficient, but for the time being it's the most expedient.

; We don't want to depend on tables.  But if we did, we might do this:
;(define (closure-hash closure)
;  (let ((cv (vector-ref (closure-template closure) 0)))  ;template-ref
;    (do ((h 0 (+ h (code-vector-ref cv i)))
;         (i (- (code-vector-length cv) 1) (- i 1)))
;        ((< i 0) h))))
;(define wna-handlers (make-table closure-hash))

(define-exception-handler (enum op check-nargs=)
  (lambda (opcode args)
    (let ((probe (assq (car args) *wna-handlers*)))
      (if probe
	  ((cdr probe) (cadr args))
	  (signal-exception opcode args)))))

(define *wna-handlers* '())

(define (define-wna-handler proc handler)
  (set! *wna-handlers* (cons (cons proc handler) *wna-handlers*)))

(define op/check-nargs= (enum op check-nargs=))

(define (wna-lose proc args)
  (signal-exception op/check-nargs= (list proc args)))

(define-wna-handler + (lambda (args) (reduce + 0 args)))

(define-wna-handler * (lambda (args) (reduce * 1 args)))

(define-wna-handler -
  (lambda (args)
    (if (and (not (null? args))
		  (null? (cdr args)))
	(- 0 (car args))
	(wna-lose - args))))

(define-wna-handler /
  (lambda (args)
    (if (and (not (null? args))
	     (null? (cdr args)))
	(/ 1 (car args))
	(wna-lose / args))))

(define-wna-handler make-vector
  (lambda (args)
    (if (and (not (null? args))
	     (null? (cdr args)))
	(make-vector (car args) (unspecific))
	(wna-lose make-vector args))))

(define-wna-handler make-string
  (lambda (args)
    (if (and (not (null? args))
	     (null? (cdr args)))
	(make-string (car args) #\?)
	(wna-lose make-string args))))

(define-wna-handler apply
  (lambda (args)
    (if (null? args)
	(wna-lose apply args))
	(apply (car args)
	       (let recur ((l (cdr args)))
		 (if (null? (cdr l))
		     (car l)
		     (cons (car l) (recur (cdr l))))))))

(define-wna-handler read-char
  (lambda (args)
    (if (null? args)
	(read-char (input-port-option args))
	(wna-lose read-char args))))

(define-wna-handler peek-char
  (lambda (args)
    (if (null? args)
	(peek-char (input-port-option args))
	(wna-lose peek-char args))))

(define-wna-handler char-ready?
  (lambda (args)
    (if (null? args)
	(char-ready? (input-port-option args))
	(wna-lose char-ready? args))))

(define-wna-handler write-char
  (lambda (args)
    (if (and (not (null? args))
	     (null? (cdr args)))
	(write-char (car args) (output-port-option (cdr args)))
	(wna-lose write-char args))))

(define-wna-handler error
  (lambda (args)
    (really-signal-condition (cons 'error args))))

(define (comparison-wna compare)	;Not really R4RS compliant.
  (lambda (args)
    (if (and (not (null? args))
	     (not (null? (cdr args))))
	(let loop ((x (car args))
		   (args (cdr args)))
	  (let ((y (car args))
		(args (cdr args)))
	    (if (compare x y)
		(if (null? args)
		    #t
		    (loop y args))
		#f)))
	(wna-lose compare args))))

(define-wna-handler = (comparison-wna =))
(define-wna-handler < (comparison-wna <))
(define-wna-handler > (comparison-wna >))
(define-wna-handler <= (comparison-wna <=))
(define-wna-handler >= (comparison-wna >=))