Small fixes to libc

compiler/implementation.lisp

@@ -45,10 +45,6 @@
 
 ;;; pointers, storage units and allocation
 
-;;; pointers are represented by conses (which never occur as C types)
-;;; an array pointer is a cons (array . index)
-;;; a place pointer is a cons (closure . nil)
-
 (defstruct memptr
   mem
   (ptr 0))
@@ -59,9 +55,11 @@
           (adjust-array unicode (1+ (length unicode)) :initial-element 0))))
 
 (defun char*-to-string (char*)
-  (let ((mem (memptr-mem char*))
+  (let ((mem   (memptr-mem char*))
         (start (memptr-ptr char*)))
-   (babel:octets-to-string mem :encoding :utf-8 :start start
+   (babel:octets-to-string mem
+                           :encoding :utf-8
+                           :start start
                            :end (position 0 mem :start start))))
 
 (defun allocate-memory (size)
@@ -79,12 +77,12 @@
 
 (defun vacietis.c:deref* (ptr)
   (etypecase ptr
-    (memptr (aref (memptr-mem ptr) (memptr-ptr ptr)))
+    (memptr    (aref (memptr-mem ptr) (memptr-ptr ptr)))
     (place-ptr (funcall (place-ptr-closure ptr)))))
 
 (defun (setf vacietis.c:deref*) (new-value ptr)
   (etypecase ptr
-    (memptr (setf (aref (memptr-mem ptr) (memptr-ptr ptr)) new-value))
+    (memptr    (setf (aref (memptr-mem ptr) (memptr-ptr ptr)) new-value))
     (plate-ptr (funcall (place-ptr-closure ptr) new-value))))
 
 ;;; arithmetic

compiler/package.lisp

@@ -6,17 +6,24 @@
    #:vacietis
    #:c-readtable
    #:string-to-char*
-   #:c-exit ;; catch/throw tag
    #:*c-structs*
    #:*basic-c-types*
    #:*type-qualifiers*
    #:*variable-types*
    #:variable-info
    #:literal
+
+   ;; memory stuff
    #:size-of
+   #:allocate-memory
+   #:memptr-mem
+   #:memptr-ptr
+
    ;; runtime
    #:run-c-program
-   #:*the-environment*))
+   #:c-exit ;; catch/throw tag
+   #:*environment*
+   ))
 
 (in-package #:vacietis)
 

libc/stdio.lisp

@@ -187,3 +187,16 @@
                            0
                            1))
     (error () 1)))
+
+;;; printf
+
+(defun printf (fmt &rest args)
+  (apply #'fprintf stdout fmt args))
+
+(defun vprintf (stream fmt &rest args)
+  )
+
+(defun sprintf (string fmt &rest args))
+
+(defun snprintf (string max-length fmt &rest args))
+

libc/stdlib.lisp

@@ -12,13 +12,18 @@
   (malloc (* count size)))
 
 (defun realloc (memory size)
-  (cond ((eql memory NULL) (malloc size))
-        ((= size 0) (setf (car memory) 'FREED_BY_REALLOC) memory)
-        (t (adjust-array (car memory) size :initial-element 0) memory)))
+  (cond ((eql memory NULL)
+         (malloc size))
+        ((= size 0)
+         (free memory)
+         NULL)
+        (t
+         (adjust-array (memptr-mem memory) size :initial-element 0)
+         memory)))
 
 (defun free (memory)
   (unless (eql NULL memory)
-    (setf (car memory) 'FREED_BY_FREE)))
+    (setf (memptr-mem memory) 'FREED_BY_FREE)))
 
 ;;; random numbers
 
@@ -103,10 +108,10 @@
   (push f *exit-functions*))
 
 (defun getenv (name)
-  (gethash name vacietis:*the-environment* NULL))
+  (gethash name vacietis:*environment* NULL))
 
 (defun setenv (name value)
-  (setf (gethash name vacietis:*the-environment*) value))
+  (setf (gethash name vacietis:*environment*) value))
 
 (defun system (command)
   0)

runtime/program.lisp

@@ -1,7 +1,7 @@
 (in-package #:vacietis)
 (in-readtable vacietis)
 
-(defvar *the-environment* (make-hash-table :test 'equal))
+(defvar *environment* (make-hash-table :test 'equal))
 
 (defun run-c-program (program-package &key
                       (stdin  *standard-input*)
@@ -11,6 +11,6 @@
     (let ((vacietis.libc.stdio.h:stdin  (make-c-stream stdin))
           (vacietis.libc.stdio.h:stdout (make-c-stream stdout))
           (vacietis.libc.stdio.h:stderr (make-c-stream stderr))
-          (*the-environment*      (make-hash-table :test 'equal)))
+          (*environment*                (make-hash-table :test 'equal)))
       (catch 'c-exit
         (funcall (find-symbol "MAIN" program-package))))))

zclib.lisp

@@ -646,96 +646,6 @@
 		  (prog1 (si:xr-read-flonum temp-string nil)
 			 (si:return-read-string temp-string)))))
 
-(defun-exporting c:|fabs| (val)
-  "Floating-point absolute value."
-  (abs val))
-
-(defun-exporting c:|floor| (x)
-  "Returns the largest integer not greater than X."
-  (float (floor x)))
-
-(defun-exporting c:|ceil| (x)
-  "Returns the smallest integer not less than X."
-  (float (ceiling x)))
-
-(defun-exporting c:|exp| (x)
-  "The exponential function, base e."
-  (exp x))
-
-(defun-exporting c:|log| (x)
-  "The logarithm, base e."
-  (log x))
-
-(defun-exporting c:|log10| (x)
-  "The logarithm, base 10."
-  (// (log x) '#,(log 10)))	  ; Want constant folding!
-
-(defun-exporting c:|pow| (x y)
-  "X to the Y power."
-  (^ x y))
-
-(defun-exporting c:|sqrt| (x)
-  "Square root."
-  (sqrt x))
-
-(deff-exporting c:|sin| 'sin)
-
-(deff-exporting c:|cos| 'cos)
-
-(deff-exporting c:|tan| 'tan)
-
-(deff-exporting c:|atan| 'atan2)
-
-(deff-exporting c:|atan2| 'atan2)
-
-(defun-exporting c:|asin| (x)
-  "Arc-sine."
-  (atan2 x (sqrt (- 1 (* x x)))))
-
-(defun-exporting c:|acos| (x)
-  "Arc-cosine."
-  (atan2 (sqrt (- 1 (* x x))) x))
-
-#+Symbolics
-(deff-exporting c:|sinh| 'sinh)
-
-#+TI
-(deff-exporting c:|sinh| 'sinh)
-
-;; CADR and Lambda don't seem to have this
-#+MIT
-(defun-exporting c:|sinh| (x)
-  (let ((exp+x (exp x)))
-    (* .5 (- exp+x (// 1.0 exp+x)))))
-
-#+Symbolics
-(deff-exporting c:|cosh| 'cosh)
-
-#+TI
-(deff-exporting c:|cosh| 'cosh)
-
-#+MIT
-(defun-exporting c:|cosh| (x)
-  (let ((exp+x (exp x)))
-    (* .5 (+ exp+x (// 1.0 exp+x)))))
-
-#+Symbolics
-(deff-exporting c:|tanh| 'tanh)
-
-#+TI
-(deff-exporting c:|tanh| 'tanh)
-
-#+MIT
-(defun-exporting c:|tanh| (x)
-  (let ((exp2x (exp (* 2.0 x))))
-    (// (- exp2x 1.0) (+ exp2x 1.0))))
-
-; This isn't quite satisfactory, because it can get intermediate overflows
-; even though the result is in range.
-(defun-exporting c:|hypot| (x y)
-  (sqrt (+ (* x x) (* y y))))
-
-
 ; ================================================================
 ; Miscellaneous.
 
@@ -744,21 +654,6 @@
   (#+Symbolics throw #-Symbolics *throw jmp_buf
    (values (if (eql val 0) 1 val) jmp_buf)))
 
-(defun-exporting c:|exit| (status)
-  "Exits the program immediately.  If STATUS is nonzero, offers to enter the
-   debugger.  (This works by signalling 'SYS:ABORT.)"
-  (and (not (zerop status))
-       (y-or-n-p
-	 (format nil "Exiting with error code = ~D.~@
-		      Enter the debugger (No means abort instead)? "
-		 status))
-       (ferror "Exiting with error code = ~D." status))
-  (signal 'sys:abort #-Symbolics ""))
-
-(defun-exporting c:|abort| ()
-  (ferror "ABORT called"))
-
-
 ; ================================================================
 ; Memory allocation.